VBA - Comparaison
Bonjour,
J'ai une macro qui permet de comparer deux tableaux et de donner la différece entre eux.
Sub test()
Dim Colonne1 As Range
Dim Colonne2 As Range
Dim suite As Range
Dim trouve As Range
'Compare la colonne A de la feuille 1 et colonne 1 de la feuille 2
Set Colonne1 = Sheets("Feuil1").Range(("A2"), Sheets("Feuil1").Range("AO2").End(xlDown))
Set Colonne2 = Sheets("Feuil2").Range(("A2"), Sheets("Feuil2").Range("A2").End(xlDown))
'Retranscrit les données différente de la feuille
For Each Cellule In Colonne1
Set suite = Sheets("Result").[A65536].End(xlUp).Offset(1, 0)
Set trouve = Colonne2.find(Cellule.Value, LookIn:=xlValues, lookat:=xlWhole)
If trouve Is Nothing Then
suite.Value = Cellule.Value
suite.Offset(0, 1).Formula = "=VLOOKUP(" & suite.Address & ",'" & Colonne1.Parent.Name & "'!" & Colonne1.Resize(, 15).Address & ",1,FALSE)"
End If
Next
End Sub
J'ai pas trouvé par quoi remplacer le
If trouve Is Nothing Then
pour dire, qu'au contraire, si il trouve la même cellule il retranscrit.... Le = ne fonctionne pas.
Merci d'avance pour vos lumières.
Nuno
Bonjour,
Peut-être :
If not trouve Is Nothing Then
A+
Bonjour,
Merci Galopin1, ça fonctionne, par contre j'ai un nouveau problème,les valeurs remonte bien mais j'ai un bug de correspondance.
Je voudrais comparer deux tables sur deux feuilles différente et pour chaque valeur trouver sur la première table me remonter tous les champs associer.
Voici mon fichier, ça sera plus parlant je pense...
Bonjour,
tu demandes (sauf erreur) de ramener par ex:
A12B3 / 1 / SQUARE dans le tableau de droite, hors dans OLD A12B3 / 1 comporte XA34KF3 donc pas SQUARE...
P.
Euh oui , c'est exact, k'ai modifier le fichier exemple avec le résultat attendu ^^
Bonsoir à tous,
Pour le fun
Option Explicit
Sub test()
Dim a, w(), e, i As Long, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.comparemode = 1
With Sheets("Matrice")
a = .Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dico.Item(a(i, 1)) = Empty
Next
With Sheets("Old")
a = .Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If dico.exists(a(i, 1)) Then
If IsEmpty(dico(a(i, 1))) Then
ReDim w(1 To 3, 1 To 1)
Else
w = dico.Item(a(i, 1))
ReDim Preserve w(1 To 3, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2)) = a(i, 1)
w(2, UBound(w, 2)) = a(i, 2)
w(3, UBound(w, 2)) = a(i, 4)
dico.Item(a(i, 1)) = w
End If
Next
For Each e In dico.keys
If IsEmpty(dico.Item(e)) Then dico.Remove e
Next
End With
With .Range("d1").CurrentRegion
With .Offset(1)
.Clear
If dico.Count > 0 Then
For i = 0 To dico.Count - 1
.Offset(n).Resize(UBound(dico.items()(i), 2)) = _
Application.Transpose(dico.items()(i))
n = n + UBound(dico.items()(i), 2)
Next
Else
MsgBox "aucune donnée à restituer"
End If
End With
End With
End With
Set dico = Nothing
End Sub
klin89
Bonjour patrick1957 & Klin89 ,
Merci beaucoup pour votre aide c'est parfait
Je viens de comprendre la logique entre For et With, merci beaucoup pour vos lumières
A bientôt
Juste dernière question,
J'ai rajouter une colonne dans la matrice à gauche de la valeur chercher. Vous savez si il est possible de la lier aux résultats ?
Je vous joins l'exemple.
Bonjour,
Le code de Klin89 est comme toujours excellent , mais comme j'ai toujours du mal avec la compréhension et qu' il y a peu de données, je continue sur mon code sans toucher à celui de Klin89.
L'avantage de son code est qu'il fonctionnera beaucoup plus vite s'il y a des milliers de lignes
Sub test()
Dim Old As Range
Dim Matrice As Range
Dim trouve As Range
Dim suite As Range
Dim Ws1, Ws2 As Worksheet
Set Ws1 = Sheets("Old"): Set Ws2 = Sheets("Matrice")
'Compare la colonne A de la feuille Matrice et colonne G de la feuille Matrice
Set Old = Ws1.Range(("A2"), Ws1.Range("A2").End(xlDown))
Set Matrice = Ws2.Range(("B2"), Ws2.Range("B2").End(xlDown))
'Retranscrit les données différente de la feuille
For Each cel In Matrice ' boucle dans la feuille Matrice
With Old ' zone de recherche en onglet OLD
Set c = .Find(cel, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Set suite = Ws2.[E65536].End(xlUp).Offset(1, 0)
FirstAddress = c.Address
Do ' boucle tant que c est c est <> ""
suite.Value = c.Value: suite.Offset(, 2) = c.Offset(, 1)
suite.Offset(0, 1) = cel.Offset(0, -1)
suite.Offset(0, 3) = c.Offset(0, 3)
Set suite = Sheets("Matrice").[E65536].End(xlUp).Offset(1, 0)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next ' cel
End Sub
Bonjour patrick1957,
Encore merci pour ton aide, oui c'es vrai que j'ai eu un peu de mal à comprendre aussi le code de Klin89 malgrès qu'il soit rapide à exécuté. Je continue à chercher le fondement de la logique pour pouvoir tout adapter.
Merci beaucoup pour ton coup de main
Re nunos31,
Salut patrick1957
Comme ceci :
Option Explicit
Sub test()
Dim a, w(), x(), e, i As Long, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.comparemode = 1
With Sheets("Matrice")
a = .Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dico.Item(a(i, 2)) = VBA.Array(a(i, 1), Empty)
Next
With Sheets("Old")
a = .Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If dico.exists(a(i, 1)) Then
w = dico.Item(a(i, 1))
If IsEmpty(w(1)) Then
ReDim x(1 To 4, 1 To 1)
Else
x = w(1)
ReDim Preserve x(1 To 4, 1 To UBound(x, 2) + 1)
End If
x(1, UBound(x, 2)) = a(i, 1)
x(2, UBound(x, 2)) = w(0)
x(3, UBound(x, 2)) = a(i, 2)
x(4, UBound(x, 2)) = a(i, 4)
w(1) = x
dico.Item(a(i, 1)) = w
End If
Next
For Each e In dico.keys
If IsEmpty(dico.Item(e)(1)) Then dico.Remove e
Next
End With
With .Range("e1").CurrentRegion
With .Offset(1)
.Clear
If dico.Count > 0 Then
For i = 0 To dico.Count - 1
.Offset(n).Resize(UBound(dico.items()(i)(1), 2)) = _
Application.Transpose(dico.items()(i)(1))
n = n + UBound(dico.items()(i)(1), 2)
Next
Else
MsgBox "aucune donnée à restituer"
End If
End With
End With
End With
Set dico = Nothing
End Sub
klin89
Bonjour,
salut Klin
dans le fichier il a indique ceci: "Pour chaque valeur trouver dans la colonne A de Matrice, reporter toutes les valeurs correspondante de la colonne A de Old en Matrice D"
donc pour chaque "serial" de Matrice colonne B, il faut ramener tout les "ref" de la colonne A mais aussi tout les PART de OLD correspondant à chaque "serial" de matrice...
(si j'ai compris)
enfin, si on devait suivre la logique des demandeurs, parfois en s’ennuierait
Bonjour patrick1957,
Oui c'est exactement ça, la logique c'est pour un sérial donné on peut avoir une autre référence, bien que celà peut rester rare dans la gestion de logistique celà peut être utiliser dans des buts de tacking plus poussé dans mon cas d'ou une double référence sur un même produits