VBA - Boucles conditions avec Find et FindNext qui posent problèmes

Version imprimable

Bonjour à tous,

voilà mon premier post sur ce forum que je parcours dans tous les sens depuis quelques temps. Je vous expose mon problème: j'ai un classeur excel une feuille ImportDonnées dans laquelle j'importe un un CSV régulièrement qui est tenu à jour. J'ai une seconde feuille que j'appelle ImportReporting qui me sert de base de travail pour mes userforms.
Selon la valeur trouvée dans la 1ere colonne de ImportDonnées je voudrais :
- que chaque nouvelle ligne soit ajoutée si elle n'existe pas dans FeuilleReporting.
- Si elle existe et que les données des colonnes B sont égales, alors les données des colonnes B a R soient mis à jour dans ImportReporting.
- Si elle existe et que les données des colonnes B sont différentes, alors je les ajoute dans ImportReporting.

Voilà 10 jours que je galère avec cette macro, à force de tourner ça dans tous les sens et de différentes manière je craque et lance un appel à l'aide. Je vous colle ici mon code qui boucle en rond.

Merci pour vos conseils, commentaires ou corrections :)

Code:

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Dim wsh1 As Worksheet, wsh2 As Worksheet
Dim ligne1 As Long, LastLig1 As Long, ligne2 As Long, LastLig2 As Long, LigneCopie As Long, i As Long
Dim C As Range
 
 
 
Sub EssaiComparaison()
 
 
 
 
 
Set wsh1 = Worksheets("ImportReporting")
Set wsh2 = Worksheets("ImportDonnées")
LastLig1 = wsh1.Cells(Rows.Count, "A").End(xlUp).Row 'comptage des lignes feuille ImportReporting
LastLig2 = wsh2.Cells(Rows.Count, "A").End(xlUp).Row 'comptage des lignes feuille ImportDonnées
 
'Pour ligne2 = 2 jusqu'à LastLig2 denière ligne de la feuille importDonnées
For ligne2 = 2 To LastLig2 'définir quel est la ligne de départ
 
 
    'recherche dans la colonne A de la feuille ImportReporting la valeur de la cellule "ligne2,"A" dans la feuille importDonnées
    With Worksheets("ImportReporting").Columns(1)
    Set C = .Find(wsh2.Cells(ligne2, "A"), LookIn:=xlValues)
 
 
    ' si l'occurence n'est pas trouvée
    If C Is Nothing Then
 
            ' Copie les données de ImportDonnées sur la dernière ligne +1 de la feuille ImportReporting
            LastLig1 = LastLig1 + 1
            wsh1.Range("A" & LastLig1, "R" & LastLig1).Value = wsh2.Range("A" & ligne2, "R" & ligne2).Value
 
 
        'Sinon
    Else
 
            FirstAddress = C.Address ' on retient l'adresse de la première occurence trouvée
            i = C.Row 'on défini le numéro de ligne de cette adresse
            'si la valeur de la colonne B de ImportReporting est différente de la valeur de la colonne "B" de ImportDonnées alors
            If wsh1.Cells(i, "B").Value <> wsh2.Cells(ligne2, "B").Value Then
                    Do
                    'Recherche prochaine occurence
                    Set C = .FindNext(C)
                    i = C.Row
                    'Boucle jusqu'à ce qu'occurence trouvée ET colonnes B de ImportDonnées et ImportReporting soient égales
                    Loop Until Not C Is Nothing And C.Address <> FirstAddress & wsh1.Cells(i, "B").Value = wsh2.Cells(ligne2, "B").Value
                    i = C.Row
 
                    ' copie sur ImportReporting les valeurs impotDonnées
                    wsh1.Range("B" & i, "R" & i).Value = wsh2.Range("B" & ligne2, "R" & ligne2).Value
                    'MsgBox ("Occurence trouvée et condition remplie, Ligne mise à jour" & C.Row)
                    'Exit Do
 
 
            'Sinon La première occurence trouvée était la bonne, mise à jour des données
            Else
                    ' Copie les données de ImportDonnées sur la dernière ligne +1 de la feuille ImportReporting
                    LastLig1 = LastLig1 + 1
                    wsh1.Range("A" & LastLig1, "R" & LastLig1).Value = wsh2.Range("A" & ligne2, "R" & ligne2).Value
            End If
 
    End If
    End With
 
 
Set C = Nothing
 
Next ligne2
 
 
End Sub

07/05/2017, 18h13
RyuAutodidacte

bonjour,
une petite recherche dans :faq: : https://vb.developpez.com/faqvba/?page=3.4.2#Find

C'est l'une des premières erreurs lorsque l'on débute

Bonjour,

merci pour le conseil. J'ai regardé et j'essaye d'adapter ce code. ;)
J'essaye de comprendre le déroulement. Je ne vois pas à quel niveauje dois inclure mes conditions. La boucle tourne sans fin avec le Loop à la 3eme occurrence trouvée.
Je me demande à quoi sert la variable PlageResult en l'état.
Ou dois-je inclure mes conditions, faut-il que je refasse des boucles ? After:=ActiveCell et xlValues m'indiquent des valeurs bizarres.

J'ai peur de ne pas avoir bien saisi le code
:(

Merci pour votre aide :)

Code:

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
54
55
56
57
58
Dim wsh1 As Worksheet, wsh2 As Worksheet
Dim ligne1 As Long, LastLig1 As Long, ligne2 As Long, LastLig2 As Long, LigneCopie As Long, i As Long
 
 
 
 
Sub EssaiComparaison()
 
Dim C As Range, PlageResult As Range, FirstAdress As String
 
Set wsh1 = Worksheets("ImportReporting")
Set wsh2 = Worksheets("ImportDonnées")
LastLig1 = wsh1.Cells(Rows.Count, "A").End(xlUp).Row 'comptage des lignes feuille ImportReporting
LastLig2 = wsh2.Cells(Rows.Count, "A").End(xlUp).Row 'comptage des lignes feuille ImportDonnées
 
'Pour ligne2 = 2 jusqu'à LastLig2 denière ligne de la feuille importDonnées
For ligne2 = 2 To LastLig2 'définir quel est la ligne de départ
 
 
    'recherche dans la colonne A de la feuille ImportReporting la valeur de la cellule "ligne2,"A" dans la feuille importDonnées
    With Worksheets("ImportReporting").Columns(1)
 
    Set C = .Find(wsh2.Cells(ligne2, "A"), After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
 
 
    ' si l'occurence est trouvée
    If Not C Is Nothing Then
 
 
            FirstAddress = C.Address ' on retient l'adresse de la première occurence trouvée
            i = C.Row 'on défini le numéro de ligne de cette adresse
 
            Do
 
                If PlageResult Is Nothing Then
                    Set PlageResult = C
                Else
                    Set PlageResult = Application.Union(C, PlageResult)
                End If
                    Set C = .FindNext(C)
 
            Loop While Not C Is Nothing And C.Address <> FirstAddress
    End If
 
       'MsgBox ("Copie sur la dernière ligne +1 de ImportReporting")
       'Copie les données de ImportDonnées sur la dernière ligne +1 de la feuille ImportReporting
            LastLig1 = LastLig1 + 1
            wsh1.Range("A" & LastLig1, "R" & LastLig1).Value = wsh2.Range("A" & ligne2, "R" & ligne2).Value
 
 
 
  End With
 
  Set C = Nothing
 
Next ligne2
 
  End Sub

07/05/2017, 22h34
RyuAutodidacte

je pourrais avoir un exemple des données (avec de fausses données bien sur) sur un fichier xlsx (pas xls ou xlsm) en montrant ce que l'on a au début sur les 2 feuilles et une feuilles en plus montrant le résultat voulu
07/05/2017, 22h40
Vincenzop22

1 pièce(s) jointe(s)

Voici le Fichier:

Je voudrais copier les données présentes dans la feuille ImportDonnées (les plus à jour) vers les bonnes lignes de la feuille ImportReporting, des colonnes B a R pour garder les bonnes annotations présentes dans les colonnes S et T d'ImportReporting.
Si la ligne n'existe pas dans ImportReporting alors copie sur la dernière ligne.

J'espère être clair, et surtout merci pour l'aide, parceque vraiment je m'accroche mais je ramePièce jointe 272554

Bonjour.

Si tu cherches une egalite sur la colonne A seulement, FIND peut etre utilise.
Mais si tu cherches une egalite sur plus d'une colonne, FIND n'est pas approprie.

Il te faut recourir a des boucles :

Code:

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
Sub EssaiComparaison()
 
Set orig = Worksheets("ImportDonnées")
 
Set dest = Worksheets("ImportReporting")
 
For i = 2 To orig.Cells(Rows.Count, "A").End(xlUp).Row
 
whatA = orig.Cells(i, "A")
whatB = orig.Cells(i, "B")
 
copier = False
For j = 2 To dest.Cells(Rows.Count, "A").End(xlUp).Row
 
If dest.Cells(j, "A") = whatA Then
 
If dest.Cells(j, "B") = whatB Then
 'Mise a jour de la ligne
 copier = True
 'ton code
 '...
 Exit For
End If
End If
Next j
If copier = False Then
 'Nouvel element sur nouvelle ligne
 'ton code
 '...
End If
 
Next i
 
End Sub

07/05/2017, 23h30
Vincenzop22

Merci pour votre aide.

DocMarti, j'essaye aussi d'adapter ton code, c'est comme ça qu'on progresse.
Je repasse vous faire un petit compte rendu dès que possible. En tout cas, merci pour votre aide précieuse. Je me ens moins seul ;)

Re,

Le forum Excel à buggué, je n'y avais plus accès (je ne sais pas si c'était que chez moi … ?)

Voilà la solution que je te propose (il faudra que tu vois les collections et comment cela marche :
grosso modo, pour chaque entrée dans une collection on insère un item (représentant une valeur, j'ai pris le n° de ligne) et une clé (comme un ID en qq sorte) qui ne peut être que unique (j'ai utilisé les ref en col A)

Code:

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
Sub MAJDonnees()
Dim Coll As New Collection, Source As Worksheet, Dest As Worksheet, i&, L&
 
    Set Source = Sheets("ImportDonnées")
    Set Dest = Sheets("ImportReporting")
 
    With Dest
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        Coll.Add i, CStr(.Cells(i, 1)) 'Je considère qu'il n'y a pas de Réf. en doublons dans ImportReporting => pas de gestion d'erreur
    Next
    End With
        Application.ScreenUpdating = False
    With Source
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            On Error Resume Next
            Coll.Add i, CStr(.Cells(i, 1))
            L = Coll(.Cells(i, 1))
            If Err.Number > 0 Then
                Dest.Range("B" & L & ":R" & L).Value = .Range("B" & i & ":R" & i).Value
            Else
                DL = Dest.Cells(Rows.Count, 1).End(xlUp)(2).Row
                Dest.Range("A" & DL & ":R" & DL).Value = .Range("A" & L & ":R" & L).Value
            End If
            On Error GoTo 0
        Next
    End With
        Application.ScreenUpdating = True
        Set Source = Nothing: Set Dest = Nothing
End Sub

Edit : il doit y avoir une erreur je pense dans le fichier exemple ou il y a des Ref. en doublons sur "ImportDOnnées", est ce le cas ?

exemples :

A0001 PARIS Pierre PARIS
A0001 Marseille Paul Marseille

A0006 Marseille Yves Marseille
A0006 Rennes Jean Rennes

08/05/2017, 10h23
Vincenzop22

Bonjour RyuAutodidacte,

merci pour la réponse, le forum n'était pas accessible chez moi aussi. Je me penche donc sur les collections.
Je n'ai pas été assez précis dans ma description, car il y a bien des doublons dans la ligne A. C'est pour cela que je cherchais à boucler avec la colonne "B":
Sur mon fichier csv source la ref en col A est unique par ville mais peut être commune lorsqu'on travaille avec l'ensemble des villes. :?

Merci encore. :)
08/05/2017, 10h34
RyuAutodidacte

re,
dans ton exemple, enlève les doublons et regarde comment marche le code en faisant du pas à pas

Par contre stp redéfini nous bien les crtières de sélection afin que l'on puisse faire un code adéquat …

sinon sur le principe que j'ai fait on peut définir les clés uniques on peut le faire aussi avec concaténation, ex : Ref. + Ville (schématiquement)

Edit : Exemple concret, si on a :

A0001 PARIS

cela fera :
clé = A0001PARIS

Edit 2 : je me retrouve aussi avec des doublons en colonne B; plusieurs fois Paris, Marseille, Bordeaux … selon l'exemple donné

le même code j'ai juste rajouter la concaténation de Ref et Ville :

Code:

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
Sub MAJDonnees2()
Dim Coll As New Collection, Source As Worksheet, Dest As Worksheet, i&, L&
 
    Set Source = Sheets("ImportDonnées")
    Set Dest = Sheets("ImportReporting")
 
    With Dest
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        Coll.Add i, CStr(.Cells(i, 1) & .Cells(i, 2)) 'Je considère qu'il n'y a pas de Réf. en doublons dans ImportReporting => pas de gestion d'erreur
        Debug.Print "Destination : Ligne " & i & " - Clé = " & .Cells(i, 1) & .Cells(i, 2)
    Next
    End With
        Application.ScreenUpdating = False
    With Source
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            On Error Resume Next
            Coll.Add i, CStr(.Cells(i, 1) & .Cells(i, 2))
            L = Coll(.Cells(i, 1) & .Cells(i, 2))
            If Err.Number > 0 Then
                Debug.Print "Source : Ligne " & Coll(.Cells(i, 1) & .Cells(i, 2)) & " - Clé = " & .Cells(i, 1) & .Cells(i, 2)
                Dest.Range("B" & L & ":R" & L).Value = .Range("B" & i & ":R" & i).Value
            Else
                Debug.Print "Source : Nouvelle ligne dans destination " & " - Clé = " & .Cells(i, 1) & .Cells(i, 2)
                DL = Dest.Cells(Rows.Count, 1).End(xlUp)(2).Row
                Dest.Range("A" & DL & ":R" & DL).Value = .Range("A" & L & ":R" & L).Value
            End If
            On Error GoTo 0
        Next
    End With
        Application.ScreenUpdating = True
        Set Source = Nothing: Set Dest = Nothing
End Sub

J'ai mis des Debug.Print pour visualiser le résultat dans la fenêtre d'exécution

08/05/2017, 13h08
Vincenzop22

Merci mille fois

au premier abord, ça à l'air de fonctionner Nickel, c'est la première fois que je me retrouve avec le bon nombre de lignes après exécution de la fonction en présence de doublons dans la colonne A dans la feuille importDOnnées et ImportREporting.
Après un rapide coup d’œil, les mises à jour semblent s'être faite correctement. Je vais le faire pas-à-pas comme tu me l'as préconisé, histoire de bien comprendre le fonctionnement.
Je teste aussi en partant de nouvelles données d'ImportDonnées.
Je vous tiens informé de la suite ;)

:D:D:D
08/05/2017, 14h37
RyuAutodidacte

il faut comprendre que dans une collection la clé est unique, donc si on a :
clé = A0001PARIS
et que l'on retombe sur la même clé à ajouter:
clé = A0001PARIS
le code va générer une erreur puisque dans une collection toutes les clés sont uniques et donc impossible d'avoir des doublons
et par conséquent l'ajout ne peut se faire

Cela veut dire que si l'on a une erreur la condition détectant cette erreur saura que l'on doit faire une mise à jour des données, dans le cas contraire on ajoute une nouvelle donnée

PS : le 1er code était OK, il fallait juste être plus explicite au départ sur les critères (entre autre il manquait la 3è feuille donnant le résultat final dans le fichier exemple joint),
comme quoi, surtout dans le codage, il faut être le plus explicite et exhaustif avec tout les tenants et aboutissants afin d'atteindre le but final;
des infos manquantes et on tombe à côté de la problématique

voilà

Bonjour,

oui c'est possible avec la méthode Find, juste en posant sur papier la logique avant d'écrire la première ligne de code !

Code:

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
Option Compare Text
 
Sub Demo()
        Dim R&, Rg As Range, Rf As Range, A$
            Set Rg = Feuil1.UsedRange.Rows
            Application.ScreenUpdating = False
   For R = 2 To Rg.Count
        With Feuil2.UsedRange.Columns(1).Cells
            Set Rf = .Find(Rg.Cells(R, 1).Value, , xlValues, xlWhole)
             If Rf Is Nothing Then
                Rg(R).Copy .Item(.Count + 1)
             Else
                A = Rf.Address
                    Do
                        If Rf(1, 2).Value = Rg.Cells(R, 2).Value Then
                            A = ""
                            Rg(R).Copy Rf
                            Exit Do
                        End If
                           Set Rf = .FindNext(Rf)
                    Loop Until Rf.Address = A
                If A > "" Then Rg(R).Copy .Item(.Count + 1)
             End If
        End With
   Next
            Application.ScreenUpdating = True
            Set Rg = Nothing:   Set Rf = Nothing
End Sub

___________________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

___________________________________________________________________________________________________________

Je suis Paris, Egypte, Stockholm, London, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

@Marc : Oui c'est possible avec Find. J'aurais du utiliser ma table a dessin.

Code:

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 EssaiComparaisonFIND() 'Docmarti
 
    Set orig = Worksheets("ImportDonnées")
 
    Set Dest = Worksheets("ImportReporting")
 
    nbrMises_A_Jour = 0
    nbrNouvellesLignes = 0
 
    For i = 2 To orig.Cells(Rows.Count, "A").End(xlUp).Row
 
        whatA = orig.Cells(i, "A")
        whatB = orig.Cells(i, "B")
 
        Set trouver = Nothing
        Set trouver = Dest.Columns(1).Find(What:=whatA, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
 
        If trouver Is Nothing Then
            copier = False
 
        Else
            copier = False
 
            Set premiere = trouver
 
            Do
 
                If Dest.Cells(trouver.Row, "B") = whatB Then
                    copier = True
                    memeligneDest = trouver.Row
                    orig.Range(orig.Cells(i, "C"), orig.Cells(i, "R")).Copy Dest.Cells(memeligneDest, "C")
                    nbrMises_A_Jour = nbrMises_A_Jour + 1
 
                Else
 
                    Set trouver = Dest.Columns(1).Find(What:=whatA, after:=trouver, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
 
                End If
 
            Loop While copier = False And trouver.Address <> premiere.Address
        End If
 
        If copier = False Then
            dernierLigne = Dest.Cells(Rows.Count, 1).End(xlUp).Row + 1
            orig.Range(orig.Cells(i, "A"), orig.Cells(i, "R")).Copy Dest.Cells(dernierLigne, "A")
            nbrNouvellesLignes = nbrNouvellesLignes + 1
        End If
 
    Next i
    Message = "Mises a jour = " & nbrMises_A_Jour & vbLf & "Nouvelles lignes = " & nbrNouvellesLignes
    MsgBox Message, vbOKOnly, orig.Name
 
End Sub

09/05/2017, 12h25
Marc-L

Salut l'ami de la Belle Province !

En fait c'était en réponse à la présentation initiale : « Voilà 10 jours que je galère » !

Mon code fonctionnant directement avec le classeur joint dans le post #5 …
09/05/2017, 12h52
RyuAutodidacte

Coucou tous,

Docmarti, je ne sais pas si ça le fait chez toi mais j'ai une erreur 448 ("Argument nommé introuvable") dans ton code en ligne 17 (je suis sur Mac)

hi Marc pas souci pour ton code, j'aurai envie de dire comme d'hab. ;)
09/05/2017, 14h51
Docmarti

Citation:

Envoyé par RyuAutodidacte

Docmarti, je ne sais pas si ça le fait chez toi mais j'ai une erreur 448 ("Argument nommé introuvable") dans ton code en ligne 17 (je suis sur Mac)

@RyuAutodidacte : Il semble qu'il n'y ait pas d'argument SearchFormat sur MAC.

Donc
sur Windows :

Code:

Set trouver = Dest.Columns(1).Find(what:=whatA, LookIn:=xlFormulas, LookAt:=xlWhole, SearchFormat:=False, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

et sur MAC :

Code:

Set trouver = Dest.Columns(1).Find(what:=whatA, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

C'est bon a savoir. Merci.
09/05/2017, 14h57
RyuAutodidacte

Re,
Merci à toi également, je ne connaissait pas cette différence :plusser:
09/05/2017, 15h16
Invité

Bonjour,
https://www.developpez.net/forums/d1...s/#post8631393

https://www.developpez.net/forums/d1...f/#post8959731
09/05/2017, 19h59
Vincenzop22

Merci à tous pour vos contributions.

J'ai retenu la solution de RyuAutodidacte qui correspond exactement à ce que je recherchais.
La clé recherchée dans mon cas est unique donc pas de problème. De plus, la vitesse d’exécution est impressionnante par rapport aux nombres de données traitées.
Vous m'avez vraiment sorti une épine du pied.

Il ne me reste plus qu'à me familiariser un peu plus avec les collections. cela m'ouvre de nouvelles perspectives.

Encore un gros merci à vous. A bientôt et vive ce forum :)