Discussion :

[panpipes]

Bonjour,

Je rencontre un problème sous VBA pour automatiser la rechercher et la copie de valeurs d'un tableau de données Excel vers un autre fichier Excel.

Je joins à ce post le fichier de base contenant les données à l'état brut (FullTest1) et le fichier avec la macro et les valeurs finales à copier.


Le fichier de données comporte en fonction des horaires les arrivées, opération et départs de plusieurs moyens de transport.
Seuls 4 de ces moyens de transport m'intéressent (Voitures 1,2,3 et 4), et je voudrais que la macro contenue dans le second fichier puisse afficher pour chaque voiture les arrivées et départ de chaque ville.

Je coince au niveau de la copie automatique de ces valeurs.

Je pense que le code doit ressembler à cela:
si le moyen de transport (colonne B) correspond à la voiture 1, et si l'activité associée (colonne E) est une arrivée, alors je copie la ville (colonne F) et l'heure d'arrivée (colonne A) dans l'onglet associé du second fichier. Je rentre cette ville comme variable, je cherche le prochain départ et je copie la date associée dans le second fichier.
Sinon je fais la même recherche pour les voitures 2,3,4
Sinon je passe à la ligne suivante tant que je ne suis pas arrivé à la fin.

Je me suis déjà aidé d'autre morceaux de codes pour ce que j'ai déjà réalisé, mais pour cette partie, je coince au niveau de la retranscription...

Je vous remercie d'avance pour le temps que vous prendrez à m'aider, et je vous souhaite un bon week-end!!!

Merci,

Panpipes

FullTest1.xlsxTest1.xlsx

[Philippe Tulliez]

Bonjour,
Une des solutions est le filtre avancé d'excel. Il permet entre autres d'exporter des lignes d'une liste de données vers une cellules cible (par exemple cellule A1, de la feuille X du même classeur ou d'un autre) et ce suivant des critères.
Si tu ne connais pas cet outil, je te conseille la lecture de ce tutoriel Les filtres avancés ou élaborés dans Excel

[Thautheme]

Bonjour Panpipes, Philippe, bonjour le forum,

J'ai pas utilisé la proposition du filtre avancé de Philippe à cause de la recherche du départ que je n'arrivais pas à intégrer. Pour que le code ci-dessous fonctionne j'ai dû renommer les onglets du fichier Test1.xlsx car dans dans ta base tu avais VOITURE 1 (avec un espace) et les onglets eux navet (oui dans ce cas on peut...) pas d'espace... J'ai aussi présumé quje les deux fichiers se trouvaient dans le même dossier...
Le code commenté :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim OS As Object 'déclare la variable OS (Onglet Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim OD As Object 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim V As String 'déclare la variable V (Ville)
Dim R As Range 'déclare la variable R (Recherche)
Dim PA As String 'déclare la variable PA (Première Adresse)
 
Set CS = ThisWorkbook 'définit la classeur soucrce CS
CH = CS.Path 'définit le chemin d'accès CH
Set OS = CS.Sheets("Feuil1") 'définit l'onglet source OS
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CD = Workbooks("Test1.xlsx") 'définit le classeur destination CD (génère une erreur si ce classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'efface l'erreur
    Workbook.Open (CH & "\Test1.xlsx") 'ouvre le classeur "Test1.xlsx"
    Set CD = ActiveWorkbook 'définit la classeur destination CD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
DL = OS.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 2 (=B) de l'onglet OS
Set PL = OS.Range("B2:B" & DL) 'définit la plage PL
For Each CEL In PL 'boucles sur toutes les cellules CEL de la plage PL
    If Left(CEL.Value, 7) = "VOITURE" Then 'condition 1 : si les 7 premièr caractères de la cellules sont "Voiture"
        Set OD = CD.Sheets(CEL.Value) 'définit l'onglet destination OD
        If CEL.Offset(0, 3).Value = "ARR" Then 'condition 2 : si l'[activité] correspondante est "ARR"
            Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'désinit la cellule de destination DEST
            V = CEL.Offset(0, 4).Value 'définit la ville V
            DEST.Value = V 'récupère la ville V dans la cellule de destination DEST
            DEST.Offset(0, 1).Value = CEL.Offset(0, -1).Value 'récupère la [Date planifiée] dans la cellule en colonne B de DEST
            'définit la recherche R (recherche la ville V, dans la colonne 6 =(F) de l'onglet OS
            Set R = OS.Columns(6).Find(V, CEL.Offset(0, 4), xlValues, xlWhole)
            'condition 3 : si il existe au moins une occurrence trouvée et que la ligne ce cette occurrence est différente de la ligne de CEL
            If Not R Is Nothing And R.Row <> CEL.Row Then
                PA = R.Address 'définit l'addresse PA de la première occurrence trouvée
                Do 'exécute
                    'condition 4 : si cellule en colonne B de l'occurrence trouvée est égale à CEl et si la cellule en colonne E est un départ "DEP"
                    If R.Offset(0, -4).Value = CEL.Value And R.Offset(0, -1).Value = "DEP" Then
                        DEST.Offset(0, 2).Value = R.Offset(0, -5).Value 'récupère la [Date planifiée] en colonne C de DEST
                        Exit Do 'sort de la boucle d'exécition
                    End If 'fin de la condition 4
                    Set R = OS.Columns(6).FindNext(R) 'redéfinit la recherche R (occurrence suivante)
                Loop While Not R Is Nothing And R.Address <> PA 'boucle tant qu'il existe de nouvelles occurrences ailleurs qu'en PA
            End If 'fin de la condition 3
        End If 'fin de la condition 2
    End If 'fin de la condition 1
Next CEL 'prochaione cellule de la boucle
End Sub

Le fichier :