Microsoft 365 Comparer 2 listes Excel

[toto89]

Bonjour à tous !

J'ai un petit problème de comparaison entre différentes listes.

Je voudrai comparer 2 listes de données d'onglet différent et faire apparaitre dans le 3eme onglet les différences.
ci joint un exemple.

Merci d'avance pour votre aide !

 

[vgendron]

petite question, est-ce possible d'ajouter une colonne et y mettre le nom de l'onglet auquel il appartient ? tjrs en vb

il suffit de modifier un peu le code

Sub compare()

Dim Dico1 As New dictionary ' CreateObject("Scripting.Dictionary")
Dim Dico2 As New dictionary ' CreateObject("Scripting.Dictionary")

With Sheets("Feuil1")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    For i = 2 To fin
        clé = .Range("A" & i) & "-" & .Range("B" & i) & "-" & .Range("C" & i)
        If Not Dico1.Exists(clé) Then
            Dico1.Add clé, "Feuil1"
        End If
    Next i
End With

With Sheets("Feuil2")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    For i = 2 To fin
        clé = .Range("A" & i) & "-" & .Range("B" & i) & "-" & .Range("C" & i)
        If Not Dico2.Exists(clé) Then
            Dico2.Add clé, "Feuil2"
        End If
    Next i
End With

With Sheets("Feuil3")
'    MsgBox Dico1.Count
'    MsgBox Dico2.Count
    For Each clé In Dico1.keys
        If Not clé = "" Then
            If Not Dico2.Exists(clé) Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3) = Split(clé, "-")
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 4) = Dico1(clé)
            End If
        End If
    Next clé
    
    For Each clé In Dico2.keys
        If Not clé = "" Then
            If Not Dico1.Exists(clé) Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3) = Split(clé, "-")
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 4) = Dico2(clé)
            End If
        End If
    Next clé
End With
Set Dico1 = Nothing
Set Dico2 = Nothing
End Sub

 

[toto89]

il suffit de modifier un peu le code

Sub compare()

Dim Dico1 As New dictionary ' CreateObject("Scripting.Dictionary")
Dim Dico2 As New dictionary ' CreateObject("Scripting.Dictionary")

With Sheets("Feuil1")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    For i = 2 To fin
        clé = .Range("A" & i) & "-" & .Range("B" & i) & "-" & .Range("C" & i)
        If Not Dico1.Exists(clé) Then
            Dico1.Add clé, "Feuil1"
        End If
    Next i
End With

With Sheets("Feuil2")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    For i = 2 To fin
        clé = .Range("A" & i) & "-" & .Range("B" & i) & "-" & .Range("C" & i)
        If Not Dico2.Exists(clé) Then
            Dico2.Add clé, "Feuil2"
        End If
    Next i
End With

With Sheets("Feuil3")
'    MsgBox Dico1.Count
'    MsgBox Dico2.Count
    For Each clé In Dico1.keys
        If Not clé = "" Then
            If Not Dico2.Exists(clé) Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3) = Split(clé, "-")
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 4) = Dico1(clé)
            End If
        End If
    Next clé
  
    For Each clé In Dico2.keys
        If Not clé = "" Then
            If Not Dico1.Exists(clé) Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3) = Split(clé, "-")
                .Range("A" & .Rows.Count).End(xlUp).Offset(0, 4) = Dico2(clé)
            End If
        End If
    Next clé
End With
Set Dico1 = Nothing
Set Dico2 = Nothing
End Sub

top ! incroyable ce que l'on peut faire avec ce VB !

Merciiii

 

[sousou]

Bonjour
Ma contribution macro deb résulat feuil 4
J'ai ajouté une comparaison en ligne
a suivre

 

[patricktoulon]

re
je te propose un code plus net et avec un seul dico

Sub test2()
    Set dico = CreateObject("scripting.dictionary")
    Dim R(1 To 2) As Variant
    'determine let tableau  à analyser de la feuil1
    R(1) = Feuil1.Range("A2:c2").Resize(Feuil1.UsedRange.Rows.Count).Value

    'determine le tableau à analyser de la feuil2
    R(2) = Feuil2.Range("A2:c2").Resize(Feuil2.UsedRange.Rows.Count).Value

    For a = 1 To 2
        For i = 1 To UBound(R(a))
            clé = R(a)(i, 1) & "|" & R(a)(i, 2) & "|" & R(a)(i, 3)
            If Not dico.Exists(clé) Then
                dico(clé) = ""
            Else
                dico.Remove (clé)
            End If
        Next i
    Next a

    With Feuil3
        'vide la feuil3 en gardant les entetes
        .[a2:c2].Resize(.UsedRange.Rows.Count).Clear
        With .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(dico.keys) + 1)
            .Value = Application.Transpose(dico.keys)

            .TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
                           TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
        End With
    End With

End Sub

 

[patricktoulon]

re
et si tu veux travailler encore plus proprement

sans split ou texttocolumn et j'en passe et des meileures
dans le dico(x) item tu y met pas le string des trois colonnes mais l'array des 3 colonnes
et a la fin la cellule xlup offset 1.resize(,3) = l'array de chaque items de clé
c'est simple

Sub test2()
    Set dico = CreateObject("scripting.dictionary")
    Dim R(1 To 2) As Variant, colonnes
  
    'détermine let tableau  à analyser de la feuil1
    R(1) = Feuil1.Range("A2:c2").Resize(Feuil1.UsedRange.Rows.Count).Value

    'détermine le tableau à analyser de la feuil2
    R(2) = Feuil2.Range("A2:c2").Resize(Feuil2.UsedRange.Rows.Count).Value

    For a = 1 To 2
        For i = 1 To UBound(R(a))
            clé = R(a)(i, 1) & "|" & R(a)(i, 2) & "|" & R(a)(i, 3)
            If Not dico.Exists(clé) Then
                dico(clé) = Array(R(a)(i, 1), R(a)(i, 2), R(a)(i, 3))
            Else
                dico.Remove (clé)
            End If
        Next i
    Next a

    colonnes = dico.Items' ceci est donc un tableau d'array !!!!!!!!!!!!!


    With Feuil3
        'vide la feuil3 en gardant les entêtes
        .[a2:c2].Resize(.UsedRange.Rows.Count).Clear
        For i = 0 To UBound(colonnes)
            .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = colonnes(i)
        Next
    End With

End Sub

 

[patricktoulon]

et là ou c'est amusant
c'est qu'avec un seul dico on zape le triplons et quadruplons etc...

alors comment faire pour travailler avec un seul dico en exceptant les double, triple ect

la chose est simple

jusqu’à maintenant je travaille avec un seul dico dans le quel je met les donnée ou les supprime si la clé existe déjà

et bien cette fois ci on supprime pas la clé mais on vide l'item(l'array à l’intérieur) sil il existe
et a la fin on inscrit dans la feuill3 seulement les clé qui ont un array pour item
et là on est sur de gérer les doublons , triplons , les quadruplons etc....

Sub test2()
    Set dico = CreateObject("scripting.dictionary")
    Dim R(1 To 2) As Variant, colonnes

    'determine let tableau  à analyser de la feuil1
    R(1) = Feuil1.Range("A2:c2").Resize(Feuil1.UsedRange.Rows.Count).Value

    'determine le tableau à analyser de la feuil2
    R(2) = Feuil2.Range("A2:c2").Resize(Feuil2.UsedRange.Rows.Count).Value

    For a = 1 To 2
        For i = 1 To UBound(R(a))
            clé = R(a)(i, 1) & "|" & R(a)(i, 2) & "|" & R(a)(i, 3)
            If Not dico.Exists(clé) Then
                dico(clé) = Array(R(a)(i, 1), R(a)(i, 2), R(a)(i, 3))
            Else
                dico(clé) = ""
            End If
        Next i
    Next a

    colonnes = dico.Items


    With Feuil3
        'vide la feuil3 en gardant les entêtes
        .[a2:c2].Resize(.UsedRange.Rows.Count).Clear
        For i = 0 To UBound(colonnes)
            If IsArray(colonnes(i)) Then
                .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = colonnes(i)
            End If
        Next

    End With

End Sub

voilà vous avez vu comment faire avec un seul dico