comparaison de liste

Sub Compare()
Dim Dico As Object, Te(), N As Long, L As Long, X As String, Clé(), Itm(), Statut As Byte
Feuil3.Cells.Clear
Set Dico = CreateObject("Scripting.dictionary")
For N = 1 To 2
   Te = Worksheets(N).UsedRange.Value
   For L = 1 To UBound(Te)
      X = Join(Array(Trim$(Te(L, 1)), Trim$(Te(L, 2)), Trim$(Te(L, 3))), " ")
      Dico(X) = Dico(X) + N: Next L, N
Clé = Dico.keys
Itm = Dico.items
For N = 0 To UBound(Clé)
   Feuil3.[A:C].Rows(N + 1).Value = Split(Clé(N), " ")
   Statut = Itm(N)
   With Feuil3.Cells(N + 1, "D")
      .Value = Choose(Statut, "Disparu", "Nouveau", "Commun")
      .Interior.ColorIndex = Choose(Statut, 4, 5, 2): End With
   Next N
End Sub

Sub Compare()
Dim Dico As Object, Te(), N As Long, L As Long, X As String, Y(), Clé(), Itm(), Statut As Byte
Feuil3.Cells.Clear
Set Dico = CreateObject("Scripting.dictionary")
ReDim Y(1 To 2)
For N = 1 To 2
   Te = Worksheets(N).UsedRange.Value
   For L = 1 To UBound(Te)
      X = Trim$(Te(L, 1)) & " " & Trim$(Te(L, 2))
      If Dico.Exists(X) Then Y = Dico(X) Else Y(3 - N) = Empty
      Y(N) = Te(L, 3): Dico(X) = Y: Next L, N
Clé = Dico.keys
Itm = Dico.items
For N = 0 To UBound(Clé)
   Feuil3.[A:B].Rows(N + 1).Value = Split(Clé(N), " ")
   Y = Itm(N)
   If IsEmpty(Y(1)) Then
      Feuil3.Cells(N + 1, "C").Value = Y(2)
      Feuil3.Cells(N + 1, "D").Value = "Nouveau"
   ElseIf IsEmpty(Y(2)) Then
      Feuil3.Cells(N + 1, "C").Value = Y(1)
      Feuil3.Cells(N + 1, "D").Value = "Disparu"
   ElseIf Y(2) <> Y(1) Then
      Feuil3.Cells(N + 1, "C").Value = Y(2)
      Feuil3.Cells(N + 1, "D").Value = "Changé: " & IIf(Y(2) > Y(1), "+", "") & Y(2) - Y(1)
   Else
      Feuil3.Cells(N + 1, "C").Value = Y(2)
      Feuil3.Cells(N + 1, "D").Value = "Commun": End If
   Next N
End Sub

Sub Compare()
Dim i&, j&, k&, b%, c%, d$, dFl$, Fl%, fFl(), t(), tf As Boolean, Dic As New Scripting.Dictionary

    fFl = Array("liste totale", "nouvelle liste") 'onglets à traiter

    b = 1: c = 3 'b = n° première colonne:c = n° dernière colonne

    dFl = "Feuil3" 'onglet de destination

    t = Array("")
    ReDim t(b To c)
    For Fl = 0 To UBound(fFl)
        i = 0
        k = 2 ^ Fl
        On Error GoTo F
        With Worksheets(fFl(Fl))
            On Error GoTo 0

            Do
                tf = False
                i = i + 1
                For j = b To c
                    t(j) = Trim(.Cells(i, j).Value)
                    tf = tf Or t(j) <> ""
                Next
                If tf Then
                    d = Join(t, "¤")
                    If Not Dic.Exists(d) Then
                        Dic.Add d, k
                    Else
                        If Dic(d) < k Then Dic(d) = Dic(d) + k
                    End If
                End If
            Loop While tf 'arrêt sur la première ligne vide

S:      End With
    Next

    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    On Error GoTo E
    With Worksheets(dFl)
        .Cells.Clear
        For i = 0 To Dic.Count - 1
            Select Case Dic.items(i)
                Case 1: d = "Disparu": j = vbGreen: k = vbBlack
                Case 2: d = "Nouveau": j = vbBlue: k = vbWhite
                Case 3: d = "Commun": j = xlNone: k = vbBlack
                Case Else: d = Empty: j = xlNone: k = vbBlack
            End Select
            With .Cells(i + 1, 1)
                .Resize(, c - b + 1).Value = Split(Dic.Keys(i), "¤")
                With .Offset(, c - b + 1)
                    .Value = d
                    .Interior.Color = j
                    .Font.Color = k
                End With
            End With
        Next
    End With
R:  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
Exit Sub

'=================== Gestion d'erreurs ===================

F:
    MsgBox "La feuille «" & fFl(Fl) & "» n'existe pas."
    Resume S
E:
    MsgBox "Erreur imprévue !"
    Resume R

End Sub