VBA - Comparer deux tableaux de structure identique
Bonjour,
Je poste ici car j'ai créé une macro (en m'inspirant de ce que j'ai trouvé sur le web, soyons modeste) qui permet de comparer des données et j'ai remarqué que pour un grand nombre de lignes, c'est très long. J'ai même l'impression que plus la macro avance dans les lignes, et plus c'est lent.
Je pose ma question tout de suite et je détaille après : peut-on l'optimiser ?
En référence, j'ai comparé 2 fois des tableaux de 100 000 lignes et ça a mis environ 1h. La première fois je pense qu'il y avait 5 colonnes à comparer (+ l'ID) et la seconde fois 7 colonnes (+ l'ID).
Le temps passé par la macro est peut être normal vu la volumétrie, mais je souhaite savoir si on peut l'optimiser.
Voici le fonctionnement :
- 1er onglet : les données de référence, avec la clé en colonne A (identifiant unique)
- 2ème onglet : les données à comparer, avec la clé en colonne A (identifiant unique)
- 3ème onglet, un bouton pour lancer la macro
La macro (stockée dans le 3ème onglet) :
- Copie la ligne d'en-tête du 1er onglet dans le 3ème.
- Va lire dans le 1er onglet la clé (colonne A) et la recherche dans le 2ème onglet via un Find.
- Si elle trouve cette clé, elle va comparer colonne par colonne les valeurs de la ligne de cet ID entre le 1er onglet et le 2nd.
- Elle marque les lignes dont au moins une valeur est modifiée en ajoutant un "X" en colonne XX.
- Chaque cellule en écart est colorisée en jaune
- Elle indique "modifiée" dans la colonne suivant la dernière colonne de données
- Les ID du 1er onglet non trouvés dans le 2ème onglet sont marqués comme nouveaux dans cette même colonne
- Les ID du 2ème onglet non trouvés dans le 1er onglet sont marqués comme nouveaux dans cette même colonne
- Si aucune valeur n'est en modifiée, aucun ID créé ou supprimée, une variable permet de le savoir à la fin et une MsgBox l'affiche.
- Un userform permet de connaitre l'avancement de la macro : temps d'exécution, ligne en cours de traitement, nombre total de lignes à traiter, et donc % d'avancement
Exemple :
1er onglet
A B C
toto 1 abc
tata 2 xy
2ème onglet
A B C
toto 8 abc
tutu 3 123
1er onglet
A B C D
toto 8 abc modifiée (j'ai mis le 8 en gras mais dans Excel sa cellule est sur fond jaune)
tata 2 xy supprimée
tutu 3 123 nouvelle
Je joins la macro avec cet exemple très simple (et très rapide) pour plus de compréhension.
Merci beaucoup pour l'aide apportée !
Bonne soirée
François
Bonjour,
un essai avec tableau (array) et dictionary qui devraient permettre de gagner énormément de temps.
Ca fonctionne sur le classeur exemple, mais un jeu d'essai plus étoffé aurait permis de meilleurs tests.
Sub Compare()
Dim F1 As Worksheet, F2 As Worksheet, F3 As Worksheet
Dim i As Long, j As Byte, Ind As Long
Dim NbModif As Long, NBNouv As Long, NBSup As Long, NbLi As Long
Dim Modif As Boolean
Dim T1, T2, T3, Dico, Cle
Application.ScreenUpdating = False
Set F1 = Worksheets("Original")
Set F2 = Worksheets("A_comparer")
Set F3 = Worksheets("Résultat")
T1 = F1.Range("A1").CurrentRegion
T2 = F2.Range("A1").CurrentRegion
ReDim T3(1 To UBound(T1, 1), 1 To UBound(T1, 2) + 1)
Set Dico = CreateObject("Scripting.Dictionary")
'**Copie ligne entête
F1.Rows(1).Copy F3.Range("A1")
'création dictionary avec clé et N° ligne de T2
For i = LBound(T2, 1) To UBound(T2, 1)
Dico(T2(i, 1)) = i
Next
'****traitement Modifié et Supprimé
For i = LBound(T1, 1) To UBound(T1, 1)
Modif = False
If Dico.Exists(T1(i, 1)) Then 'si t1 existe dans T2
'vérification des "champs"
For j = 2 To UBound(T1, 2)
If T2(i, j) <> T1(Dico(T1(i, 1)), j) Then Modif = True
Next
If Modif Then
NbModif = NbModif + 1
NbLi = NbLi + 1
For j = 1 To UBound(T1, 2)
T3(NbLi, j) = T2(Dico(T1(i, 1)), j)
Next
T3(NbLi, UBound(T3, 2)) = "Modifiée"
'Dico.Remove (T1(i, 1))
End If
Dico.Remove (T1(i, 1))
Else ' si T1 n'existe pas dans T2
NBSup = NBSup + 1
NbLi = NbLi + 1
For j = 1 To UBound(T2, 2)
T3(NbLi, j) = T1(i, j)
Next
T3(NbLi, UBound(T3, 2)) = "Supprimée"
End If
Next
'*** traitement nouvelle
For Each Cle In Dico.keys
NBNouv = NBNouv + 1
NbLi = NbLi + 1
Ind = Dico(Cle)
For j = 1 To UBound(T2, 2)
T3(NbLi, j) = T2(Ind, j)
Next
T3(NbLi, UBound(T3, 2)) = "Nouvelle"
Next
'* "collage" du résultat
F3.Range("A2").Resize(NbLi, UBound(T3, 2)) = T3
Application.ScreenUpdating = True
If NbModif + NBSup + NBNouv > 0 Then MsgBox NbModif & " lignes modifiées" & vbLf & NBSup & " lignes supprimées" & vbLf & NBNouv & " lignes nouvelles"
End Sub
Le fond jaune des modif n'est pas pris en compte.Ce n'est pas possible directement par tableau.
Si après essais le gain de temps est significatif (combien ?), je m'y pencherai.
A+
Bonjour AlgoPlus,
Merci beaucoup pour ta réponse, le dictionnaire semble en effet infiniment plus rapide
J'ai fait un test rapide avec le fichier de test en ajoutant des clés bidons "aaa1", "aaa2", etc jusqu'à 100 000 environ dans le 1er onglet, en ajoutant des données dans la colonne B, cela dure quelques secondes seulement !
En revanche, quand j'ai voulu tester avec un de mes fichiers j'ai eu un message "L'indice n'appartient pas à la sélection". Je me suis douté qu'il y avait un compteur quelque part qui allait trop loin, et j'ai mis un peu de temps à comprendre que l'erreur arrive quand le 2ème onglet a plus de lignes que le 1er !
Si j'ai 2 lignes dans le 1er onglet et 3 lignes dans le second, ça plante.
Le problème survient ici :
'*** traitement nouvelle
For Each Cle In Dico.keys
NBNouv = NBNouv + 1
NbLi = NbLi + 1
Ind = Dico(Cle)
For j = 1 To UBound(T2, 2)
T3(NbLi, j) = T2(Ind, j)
Next
T3(NbLi, UBound(T3, 2)) = "Nouvelle"
Next
T3 ne possède que 3 clés dans ce cas, alors qu'on a besoin d'insérer des données dans T3(4).
Comment gérer ce cas ? Faut-il au moment de traiter les nouvelles lignes comparer T2 et T3 et ajouter autant de clés manquantes dans T3 ?
Merci pour ton aide.
François
T3 ne possède que 3 clés dans ce cas, alors qu'on a besoin d'insérer des données dans T3(4).
Je suis parti du principe que T1 et T2 avait le même nombre de colonnes (dans l'exemple du classeur 3)
Dès que ces tableaux sont initialisés, je redimentionne T3 (qui contiendra les résultats)
la deuxième dimension= 1 To UBound(T1, 2) + 1 soit dans l'exemple : 4 , donc une de plus pour mettre l'info (modifiée, supprimée ...)
la première dimension je l'ai dimentionné arbitrairement sur la première dimension de T1 pensant qu'il n'y aurait pas beaucoup de lignes à signaler, donc: 1 To UBound(T1, 1)
En fait il peut y avoir autant d'anomalies que de ligne en T1 plus toutes les lignes de T2 inconnues en T1, soit une première dimension qui devrait être : taille de T1 + pratiquement taille de T2
L'erreur se déclenche parce qu'on essaye d'écrire plus de lignes que T3 ne peut en contenir .
En modifiant le ReDim T3 en
ReDim T3(1 To UBound(T1, 1) + UBound(T2, 1), 1 To UBound(T1, 2) + 1)
ça va passer!
Par ailleurs, aucun traitement n'est réalisé en feuille "Original" :
- les lignes n'existant plus en feuille "A_comparer" ne sont pas supprimées
- les lignes nouvelles en feuille "A_comparer" ne sont pas ajoutées
- les lignes existantes de chaque coté avec des valeurs différentes ne sont pas mises à jour
Faut-il l'envisager ?
A+
Merci beaucoup, ça marche encore mieux maintenant !
J'ai fait le test avec toujours des "aaa1", "aaa2"... en feuille "Original", j'ai ajouté des "bbb1", "bbb2"... en feuille "A_comparer", tout est exécuté correctement en quelques secondes. Indéniablement et infiniment plus rapide, merci.
En revanche, une fois testé sur un de mes fichiers de données, j'ai une erreur, toujours "L'indice n'appartient pas à la sélection". Après recherche, il intervient ici :
'****traitement Modifié et Supprimé
For i = LBound(T1, 1) To UBound(T1, 1)
Modif = False
If Dico.Exists(T1(i, 1)) Then 'si t1 existe dans T2
'vérification des "champs"
For j = 2 To UBound(T1, 2)
If T2(i, j) <> T1(Dico(T1(i, 1)), j) Then Modif = True <= erreur ici
Next
Voici le contexte :
nombre de lignes de T1 : 102 039
nombre de colonnes de T1 : 6
nombre de lignes de T2 : 108 456
nombre de colonnes de T2 : 6
nombre de lignes de T3 : 210 495
nombre de colonnes de T3 : 7
i = 95 635
j = 2
Dico(T1(i, 1)) = 102 040
C'est là que ça coince, T1 ne fait que 102 039 lignes et on cherche sa valeur en 102 040. Malgré tout ça, je n'arrive pas vraiment à comprendre d'où vient le problème...
Désolé mais les données ne m'appartiennent pas, je ne peux pas fournir le fichier tel quel, et anonymiser prendrait un temps fou (ou alors je veux bien la technique pour le faire rapidement et que le traitement de la macro reste similaire !).
Par ailleurs, aucun traitement n'est réalisé en feuille "Original" :
- les lignes n'existant plus en feuille "A_comparer" ne sont pas supprimées
- les lignes nouvelles en feuille "A_comparer" ne sont pas ajoutées
- les lignes existantes de chaque coté avec des valeurs différentes ne sont pas mises à jour
Faut-il l'envisager ?
Dans mon cas, non. Je cherche uniquement à comparer des données, je ne cherche pas à la mettre à jour. Il s'agit en fait de données issues de bases de données qui dont les flux sont migrés. Le flux original et le flux migré peuvent donc être techniquement différents, mais je souhaite que les données soient les mêmes à la fin. Il se peut pour des raisons de jeux de tests que des données existent dans l'un et pas dans l'autre (les nouvelles et les supprimées), mais le plus important pour moi concerne les lignes modifiées !
C'est pour cela que j'avais trouvé intéressant de mettre un fond jaune sur les cellules modifiées.
Encore merci pour l'aide apportée !
François
Ben oui... je ne comprend pas comment ça ramenait les bonnes valeurs !!
If T2(i, j) <> T1(Dico(T1(i, 1)), j) Then Modif = True
est absurde. évidemment il faut :
If T1(i, j) <> T2(Dico(T1(i, 1)), j) Then Modif = True
pour mettre en évidence les valeurs modifiées deux solutions:
1) indiquer dans une colonne supplémentaire de T3 les N° de colonnes modifiées.
"coller" le tableau dans la feuille résultat
rajouter une moulinette dans la macro , qui va parcourir cette colonne supplémentaire pour colorer les colonnes nécessaires
supprimer cette colonne supplémentaire.
2)dans la feuille résultats ne copier que les valeurs qui ont été modifiées, les autres restant vides.
( sauf la clé )
A+
En effet, ça marche beaucoup mieux comme ça ! Je n'avais pas vu la coquille...
Résultat :
4770 lignes modifiées
5580 lignes supprimées
11997 lignes nouvelles
Environ 4 secondes !
Encore merci beaucoup pour l'aide !
Je me lancerai un peu plus tard dans la peinture, merci pour les conseils
A+
François
Ca y est, j'ai joué les peintres
Ca fonctionne, maintenant je poste quand même mon code ici pour savoir si c'est propre, optimisé, hasardeux, pourri (rayez les mentions inutiles)
J'ai choisi la première option, comme dans ma précédente macro, car je souhaite conserver l'ensemble des données et mettre en valeur les cellules modifiées.
Sub Compare()
Dim F1 As Worksheet, F2 As Worksheet, F3 As Worksheet
Dim i As Long, j As Byte, Ind As Long, k As Long
Dim NbModif As Long, NBNouv As Long, NBSup As Long, NbLi As Long
Dim Modif As Boolean
'Dim Tableau() As String
Dim T1, T2, T3, Dico, Cle, ColModifs
Application.ScreenUpdating = False
Set F1 = Worksheets("Original")
Set F2 = Worksheets("A_comparer")
Set F3 = Worksheets("Résultat")
T1 = F1.Range("A1").CurrentRegion
T2 = F2.Range("A1").CurrentRegion
'ReDim T3(1 To UBound(T1, 1) + UBound(T2, 1), 1 To UBound(T1, 2) + 1)
ReDim T3(1 To UBound(T1, 1) + UBound(T2, 1), 1 To UBound(T1, 2) + 2)
Set Dico = CreateObject("Scripting.Dictionary")
'**Suppression du contenu de la feuille "Résultat"
F3.Cells.Clear
'**Copie ligne entête
F1.Rows(1).Copy F3.Range("A1")
'création dictionary avec clé et N° ligne de T2
For i = LBound(T2, 1) To UBound(T2, 1)
Dico(T2(i, 1)) = i
Next
'****traitement Modifié et Supprimé
For i = LBound(T1, 1) To UBound(T1, 1)
ReDim ColModifs(UBound(T1, 2) - 2)
Modif = False
If Dico.Exists(T1(i, 1)) Then 'si t1 existe dans T2
'vérification des "champs"
For j = 2 To UBound(T1, 2)
If T1(i, j) <> T2(Dico(T1(i, 1)), j) Then
Modif = True
ColModifs(j - 2) = j
Else
ColModifs(j - 2) = 0
End If
Next
If Modif Then
NbModif = NbModif + 1
NbLi = NbLi + 1
For j = 1 To UBound(T1, 2)
T3(NbLi, j) = T2(Dico(T1(i, 1)), j)
Next
T3(NbLi, UBound(T3, 2) - 1) = "Modifiée"
T3(NbLi, UBound(T3, 2)) = ColModifs 'ajout des numéros de colonnes modifiées
'Dico.Remove (T1(i, 1))
End If
Dico.Remove (T1(i, 1))
Else ' si T1 n'existe pas dans T2
NBSup = NBSup + 1
NbLi = NbLi + 1
For j = 1 To UBound(T2, 2)
T3(NbLi, j) = T1(i, j)
Next
T3(NbLi, UBound(T3, 2) - 1) = "Supprimée"
End If
Next
'*** traitement nouvelle
For Each Cle In Dico.keys
NBNouv = NBNouv + 1
NbLi = NbLi + 1
Ind = Dico(Cle)
For j = 1 To UBound(T2, 2)
T3(NbLi, j) = T2(Ind, j)
Next
T3(NbLi, UBound(T3, 2) - 1) = "Nouvelle"
Next
'* "collage" du résultat
If NbModif + NBSup + NBNouv > 0 Then
F3.Range("A2").Resize(NbLi, UBound(T3, 2)) = T3
'***Traitement des cellules modifiées
For i = 1 To NbModif
For j = 0 To UBound(T1, 2) - 2
If T3(i, UBound(T3, 2) - 1) = "Modifiée" Then
k = T3(i, UBound(T3, 2))(j)
If k > 0 Then
Cells(i + 1, k).Interior.ColorIndex = 6 ' On colorise les cellules modifiées
End If
End If
Next
Next
MsgBox NbModif & " lignes modifiées" & vbLf & NBSup & " lignes supprimées" & vbLf & NBNouv & " lignes nouvelles"
Else
MsgBox "Aucune modification" & vbLf & "Aucune suppression" & vbLf & "Aucun ajout"
End If
Application.ScreenUpdating = True
End Sub
Merci
François
EDIT : J'ai ajouté un test pour le cas où il n'y aurait aucune modification/ajout/suppression
Si la macro n'est pas lancée depuis la feuille de résultats ( a priori ça n'arrivera pas , mais ...)la couleur risque de ne pas être mise sur la bonne feuille:
F3.Cells(i + 1, k).Interior.ColorIndex = 6 ' On colorise les cellules...
Pour la coloration des lignes:
Les dernières lignes de T3 sont les lignes nouvelles, donc les premières sont les lignes modifiées et les lignes supprimées dans le désordre.
For i = 1 To NbModif, ne parcourra pas l'ensemble des lignes modifiées et supprimées
il faudrait :
For i = 1 To NbModif + NBSup
Si T1 n'a que 3 colonnes (comme dans le classeur test) avec avec For j = 0 To UBound(T1, 2) - 2 , on se limite à la première "colonne". Il faudrait peut -être
For j = 0 To UBound(T3, 2) - 2
Finalement, pas sûr que cette ligne soit indispensable.... à voir
Bonne soirée
Edit : 15 s au lieu d'une heure , ça valait le coup d'optimiser.
Dommage pour le module de visualisation de l'avancement du traitement ...
Pour la gestion des colonnes à coloriser:
puisque ces N° de colonnes sont stockés dans un tableau (ColModifs) pendant le traitement, autant utiliser ce tableau par balayage pour connaitre les colonnes à coloriser.
'***Traitement des cellules modifiées
For i = 1 To NbModif + NBSup
'For j = 0 To UBound(T1, 2) - 2 'ligne supprimée
If T3(i, UBound(T3, 2) - 1) = "Modifiée" Then
k = T3(i, UBound(T3, 2)) 'on met le tableau des N° de colonnes dans un tableau k
For x = LBound(k) To UBound(k) 'du premier au dernier élément de k
If k(x) > 0 Then Cells(i + 1, k(x)).Interior.ColorIndex = 6 ' On colorise les cellules modifiées
Next
End If
'Next
Next
MsgBox NbModif & " lignes modifiées" & vbLf & NBSup & " lignes supprimées" & vbLf & NBNouv & " lignes nouvelles"
Else
.../...
ce qui oblige à modifier la déclaration de k (à déclarer comme ColModifs) et à déclarer x as long
Peut-être prévoir un Erase du tableau ColModifs, qui pourrait conserver des données de l'itération précédente.
C'est tout pour aujourd'hui ...
Bonjour AlgoPlus,
Merci pour les conseils, j'ai modifié tout ça
J'ai ajouté un startdate et endate pour avoir le temps écoulé réel, pour ce post (je ne m'en servirai pas), et voici le résultat pour un fichier de 5 colonnes (clé comprise) x 102 039 lignes originales et 108 456 lignes à comparer :
Peut-être prévoir un Erase du tableau ColModifs, qui pourrait conserver des données de l'itération précédente.
A priori pas besoin, la fonction Redim efface le contenu du tableau. Il faudrait faire un Redim Preserve pour conserver les données (corrige moi si je me trompe).
C'est pour cela que je l'ai mise au début de la boucle du traitement modifié/supprimé
'****traitement Modifié et Supprimé
For i = LBound(T1, 1) To UBound(T1, 1)
ReDim ColModifs(UBound(T1, 2) - 2)
Merci pour l'aide apportée, elle m'est précieuse !
Je passe le sujet en résolu
Bonne journée
François
Mea culpa : je n'avais pas fait attention au ReDim.
4 secondes , colorisation comprise ! je pensais que cette étape serait plus gourmande !
Bon courage et bonne suite