Microsoft 365 Comparaison de tableaux !

[Patrosso]

Bonjour à toutes et a tous,
Voilà le deuxième problème que je rencontre pour la comparaison de mes deux tableaux. J'ai grâce a vous un algorithme ou disons une fonction, qui compare deux noms entre eux et qui renvoi un pourcentage de "match", c'est top ca marche nickel. Voila l'application qui me pause soucis maintenant (je ne compte pas apprendre vraiment vba j'en ai juste besoin ici pour faire quelquechose pour stage, j'apprendrait peut être plus tard qui sait, donc soyez explicite s'il vous plait ahah). J'aimerais pouvoir comparer mon Tableau 1 a mon Tableau 2 (avec un nombres de noms/prénoms différents) pour voir ressortir tous les noms en communs ainsi que leur pourcentage de match. C'est a dire imaginons que dans la liste 1 on a : Jean, Mathieu, Théo, Léo, Michel et dans la liste 2 Gérard, bertrand, Matthieu (cette fois avec deux T), Léo, on aurait a coté une colonne qui nous sortirait : Mathieu 90% ou je ne sais combien (l'algorithme me le donnera le pourcentage est pas important c'est pour l'exemple) et Léo 100%.
Franchement Si vous arrivez a m'aider la dessu ca sera toppp. Comme je vous l'ai dit j'ai un algorithme qui me permet de comparer deux noms et un autre qui me permet de comparer deux tableaux mais qui sort des valeurs seulement si le match est parfait dans notre cas précdédent Léo sortirait mais pas mathieu et c'est la qu'est le problème.
Jèspere avoir été suffisament clair je vous mets les deux algo ou "fonction que j'utilise" en copie

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

'Code Pour Comparer les deux tableaux et sortir les différences/ Matchs

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

J’espère que vous pourrez m'aider merci d'avance
Léo

 

[Patrosso]

En bref j'aimerais combiner les deux quoi c'est ptete plus simple dit comme ca ahah, sauf que j'y connais rien en vba moi
Leo