Comparaison de 2 tableaux Excel et création d'un 3ème tableau contenant les différences ou les éléments communs

ComparaisonTableaux.vba

Option Explicit
Option Base 1
Public Enum ComparisonMode
    xDifferences = 1
    xMatches = 2
End Enum

Public Sub ComparerTableaux()

' Modifiez le code ci-dessous pour l'adapter à vos besoins :
' - noms des feuilles contenant les tableaux (Feuil1, Feuil2)
' - noms des tableaux (TableauA, TableauB)
' - numéros de la première et de la dernière colonne de la plage de colonnes à comparer (1, 3)
' (Pour comparer selon une seule colonne, mettez 2 numéros identiques)
' - xDifferences pour extraire les différences ou xMatches pour extraire les éléments communs

BuildComparisonResult Worksheets("Feuil1").ListObjects("TableauA"), _
                   Worksheets("Feuil2").ListObjects("TableauB"), 1, 3, _
                   xDifferences, ActiveCell

End Sub

' La première cellule de ce tableau est la cellule active de la feuille
' Paramètres :
'  - les objets tableaux et les N° de colonnes à comparer,
'  - le mode de comparaison (différences ou similitudes)
'  - la cellules à partir de laquelle créer le tableau de résultat
Public Sub BuildComparisonResult(list1 As ListObject, list2 As ListObject, _
               colIndex1 As Integer, colIndex2 As Integer, _
                        compMode As ComparisonMode, rgInit As Range)
                     
If colIndex1 > colIndex2 Or colIndex1 > list1.ListColumns.Count Or colIndex1 > list2.ListColumns.Count Or _
   colIndex2 > list1.ListColumns.Count Or colIndex2 > list2.ListColumns.Count Then
   MsgBox "Vous devez spécifier des N° de colonnes inférieurs ou égaux aux nombres de colonnes de chacun des tableaux." & vbCrLf & vbCrLf & _
          "Le premier N° doit être inférieur ou égal au second.", vbCritical, "Erreur sur les N° de colonnes"
   Exit Sub
End If
                     
' On compare les tableaux en prenant le premier comme référence
Dim coll1 As Collection
Set coll1 = CompareListObjects(list1, list2, colIndex1, colIndex2, compMode)

' Si on cherche les différences, il faut aussi comparer dans l'autre sens
' c'est à dire en prenant le second tableau comme référence
If compMode = xDifferences Then
   Dim coll2 As Collection
   Set coll2 = CompareListObjects(list2, list1, colIndex1, colIndex2, compMode)
End If

' S'il n'y a aucun résultat à afficher, on affiche un message et on ne va pas plus loin
If compMode = xMatches Then
   If coll1.Count = 0 Then
      MsgBox "Il n'y a aucune valeur commune aux 2 tableaux", vbInformation
      Exit Sub
   End If
Else
   If coll1.Count = 0 And coll2.Count = 0 Then
      MsgBox "Les 2 tableaux sont identiques", vbInformation
      Exit Sub
   End If
End If

' En-têtes du tableau de résultat
Dim c As Long
For c = 1 To colIndex2 - colIndex1 + 1
   rgInit.Offset(0, c - 1).Value2 = list1.HeaderRowRange(1, c + colIndex1 - 1).Value2
Next

' Lignes de résultats de la première comparaison
Dim i As Long
For i = 1 To coll1.Count
   For c = colIndex1 To colIndex2
      rgInit.Offset(i, c - colIndex1).Value2 = coll1(i)(c)
   Next c
Next i

' Si on cherche les différences, on ajoute les résultats de la seconde comparaison
If compMode = xDifferences Then
   rgInit.Offset(0, colIndex2 - colIndex1 + 1).Value2 = "Tableau" ' en-tête de la colonne Tableau
   
   ' Valeur de la colonne Tableau pour toutes les lignes issues de la première comparaison
   If coll1.Count > 0 Then rgInit.Offset(1, colIndex2 - colIndex1 + 1).Resize(coll1.Count, 1).Value2 = 1
   
   ' Résultats de la seonde comparaison
   For i = 1 To coll2.Count
      For c = colIndex1 To colIndex2
         rgInit.Offset(coll1.Count + i, c - colIndex1).Value2 = coll2(i)(c)
      Next c
   Next i

   ' Valeur de la colonne Tableau pour toutes les lignes issues de la seconde comparaison
   If coll2.Count > 0 Then
      rgInit.Offset(coll1.Count + 1, colIndex2 - colIndex1 + 1).Resize(coll2.Count, 1).Value2 = 2
   End If
End If

' On crée un objet tableau à partir des résultats générés précédemment
' et on le trie selon la première colonne
Dim lstObj As ListObject
Set lstObj = ActiveSheet.ListObjects.Add(xlSrcRange, rgInit.CurrentRegion, , xlYes)
With lstObj
   .TableStyle = "TableStyleLight14"
   .ShowTotals = True
   .ListColumns(1).TotalsCalculation = xlTotalsCalculationCount
   If .ListColumns.Count > 1 Then
      .ListColumns(.ListColumns.Count).TotalsCalculation = xlTotalsCalculationNone
   End If

   If Not .ListColumns(1).DataBodyRange Is Nothing Then
      .Sort.SortFields.Add2 Key:=.ListColumns(1).DataBodyRange
      .Sort.Apply
   End If
End With

' Ajoute un titre au-dessus du tableau
'rgInit.Offset(-1, 0).Value2 = IIf(compMode = xMatches, "Valeurs communes", "Différences")

End Sub

' Compare 2 tableaux selon une plage de colonnes délimitée par 2 indices
' Le 1er tableau est la référence
' La fonction renvoie le résultat sous forme d'une collection contenant :
' - Si compType = xDifferences : les éléments présents dans le premier tableau et pas dans le second
' - Si compType = xMatches : les éléments présents dans les 2 tableaux
Private Function CompareListObjects(list1 As ListObject, list2 As ListObject, _
                         colIndex1 As Integer, colIndex2 As Integer, compMode As ComparisonMode)

Dim ar1()  ' Pour stocker les elts du premier tableau à comparer
Dim ar2()  ' Pour stocker les elts du second tableau à comparer

' On récupère les valeurs des tableaux à comparer
ar1 = list1.DataBodyRange.Value2
ar2 = list2.DataBodyRange.Value2

Dim matches As New Collection ' Pour stocker les elts qui correspondent
Dim differences As New Collection   ' Pour stocker les elts sans correpondance
Dim i As Long
Dim j As Long
Dim k As Long
Dim matchRow As Boolean
Dim matchCol As Boolean

For i = 1 To UBound(ar1, 1)
   matchRow = False
   For j = 1 To UBound(ar2, 1)
      matchCol = True
      For k = colIndex1 To colIndex2
         If ar1(i, k) <> ar2(j, k) Then
            matchCol = False
            Exit For
         End If
      Next k
      ' Si les valeurs de toutes les colonnes sont identiques,
      ' on ajoute la ligne à la liste des lignes qui correspondent
      If matchCol Then
         matchRow = True
         matches.Add Application.WorksheetFunction.Index(ar1, i, 0)
         Exit For
      End If
   Next j
   If Not matchRow Then
      differences.Add Application.WorksheetFunction.Index(ar1, i, 0)
   End If
Next i

If compMode = xDifferences Then
   Set CompareListObjects = differences
Else
   Set CompareListObjects = matches
End If

End Function

Cette 3ème version prend en charge la comparaison selon plusieurs colonnes adjacentes.