Skip to content

Instantly share code, notes, and snippets.

@developpeur-pro
Last active July 4, 2023 16:01
Show Gist options
  • Save developpeur-pro/cda9795ed80617929d1f837a081acec1 to your computer and use it in GitHub Desktop.
Save developpeur-pro/cda9795ed80617929d1f837a081acec1 to your computer and use it in GitHub Desktop.
Comparaison de 2 tableaux Excel et création d'un 3ème tableau contenant les différences ou les éléments communs
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
@developpeur-pro
Copy link
Author

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment