Microsoft 365 Comparaison de tableaux !

Option Explicit


'Pour comparer deux noms (trouvé sur le forum et qui marche tiptop) :

Public Function similaire(ByVal s1 As String, ByVal s2 As String) As Double
 
    Const cFacteur As Long = &H100&, cMaxLen As Long = 256&   'Longueur maxi autorisée des chaines analysées
    Dim l1 As Long, l2 As Long, c1 As Long, c2 As Long
    Dim r() As Integer, rp() As Integer, rpp() As Integer, i As Integer, j As Integer
    Dim c As Integer, x As Integer, y As Integer, z As Integer, f1 As Integer, f2 As Integer
    Dim dls As String, ac1() As Byte, ac2() As Byte
    l1 = Len(s1): l2 = Len(s2)
    If l1 > 0 And l1 <= cMaxLen And l2 > 0 And l2 <= cMaxLen Then
        ac1 = s1: ac2 = s2   'conversion des chaines en tableaux de bytes
        'Initialise la ligne précédente (rp) de la matrice
        ReDim rp(0 To l2)
        For i = 0 To l2: rp(i) = i: Next i
        For i = 1 To l1
            'Initialise la ligne courante de la matrice
            ReDim r(0 To l2): r(0) = i
            'Calcul le CharCode du caractère courant de la chaine
            f1 = (i - 1) * 2: c1 = ac1(f1 + 1) * cFacteur + ac1(f1)
            For j = 1 To l2
                f2 = (j - 1) * 2: c2 = ac2(f2 + 1) * cFacteur + ac2(f2)
                c = -(c1 <> c2)   'Cout : True = -1 => c = 1
                'suppression, insertion, substitution
                x = rp(j) + 1: y = r(j - 1) + 1: z = rp(j - 1) + c
                If x < y Then
                    If x < z Then r(j) = x Else r(j) = z
                Else
                    If y < z Then r(j) = y Else r(j) = z
                End If
                'transposition
                If i > 1 And j > 1 And c = 1 Then
                    If c1 = ac2(f2 - 1) * cFacteur + ac2(f2 - 2) And c2 = ac1(f1 - 1) * cFacteur + ac1(f1 - 2) Then
                        If r(j) > rpp(j - 2) + c Then r(j) = rpp(j - 2) + c
                    End If
                End If
            Next j
            'Reculer d'un niveau la ligne précédente (rp) et courante (r)
            rpp = rp: rp = r
        Next i
        'Calcul la similarité via la distance entre les chaines r(l2)
        If l1 >= l2 Then dls = 1 - r(l2) / l1 Else dls = 1 - r(l2) / l2
    ElseIf l1 > cMaxLen Or l2 > cMaxLen Then
        dls = -1   'indique un dépassement de longueur de chaine
    ElseIf l1 = 0 And l2 = 0 Then
        dls = 1   'cas particulier
    End If
    similaire = dls * 100
End Function

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

Public Sub ComparerTableaux()
BuildComparisonResult ActiveSheet.ListObjects("Tableau133"), 1, _
                    ActiveSheet.ListObjects("Tableau4"), 1, _
                    xMatches, ActiveCell

End Sub

' Crée un 3ème tableau contenant le résultat de la comparaison des 2 tableaux
' 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, colIndex1 As Integer, _
                        list2 As ListObject, colIndex2 As Integer, _
                        compMode As ComparisonMode, _
                        rgInit As Range)
                    
' On compare les tableaux en prenant le premier comme référence
Dim coll1 As Collection
Set coll1 = CompareListObjects(list1, 1, list2, 1, 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, 1, list1, 1, 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ête de la première colonne du tableau de résultat
If compMode = xMatches Then
   rgInit.Value2 = "Valeurs communes"
Else
   rgInit.Value2 = "Différences"
End If

' On affiche les résultats de la première comparaison
Dim i As Long
For i = 1 To coll1.Count
   rgInit.Offset(i, 0).Value2 = coll1(i)
Next i

' Si on cherche les différences, on affiche les résultats de la seconde comparaison
If compMode = xDifferences Then
   rgInit.Offset(0, 1).Value2 = "Tableau" ' en-tête de la seconde colonne
  
   If coll1.Count > 0 Then rgInit.Offset(1, 1).Resize(coll1.Count, 1).Value2 = 1
  
   For i = 1 To coll2.Count
      rgInit.Offset(coll1.Count + i, 0).Value2 = coll2(i)
   Next i

   If coll2.Count > 0 Then
      rgInit.Offset(coll1.Count + 1, 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(2).TotalsCalculation = xlTotalsCalculationNone
   End If
   .Sort.SortFields.Add2 Key:=.ListColumns(1).DataBodyRange
   .Sort.Apply
End With

End Sub

' Compare 2 tableaux selon les colonnes choisies, en prenant le 1er comme référence
' 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, colIndex1 As Integer, _
                        list2 As ListObject, 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.ListColumns(colIndex1).DataBodyRange.Value2
ar2 = list2.ListColumns(colIndex2).DataBodyRange.Value2

Dim collMatch As New Collection ' Pour stocker les elts qui correspondent
Dim collDif As New Collection   ' Pour stocker les elts sans correpondance
Dim i As Long
Dim j As Long
Dim match As Boolean

For i = 1 To UBound(ar1)
   match = False
   For j = 1 To UBound(ar2)
      If ar1(i, 1) = ar2(j, 1) Then
         collMatch.Add ar1(i, 1)
         match = True
         Exit For ' On arrête dès que l'élément a été trouvé
      End If
   Next j
   If Not match Then
      collDif.Add ar1(i, 1)
   End If
Next i

If compMode = xDifferences Then
   Set CompareListObjects = collDif
Else
   Set CompareListObjects = collMatch
End If

End Function