XL pour MAC Surligner les mots similaire dans une liste

Sub Compare()
Dim t, CollectLigne As New Collection, tablo, resu(), i&, x$, j%, y$, car$, k%, c$
t = Timer
On Error Resume Next
With [A1].CurrentRegion
    tablo = .Resize(, 2) 'matrice plus rapide, au moins 2 éléments
    ReDim resu(1 To UBound(tablo), 1 To 1)
    '---collection des textes réduits ou remplacés---
    For i = 2 To UBound(tablo)
        x = LCase(tablo(i, 1))
        For j = 1 To Len(x)
            y = Left(x, j - 1) & Mid(x, j + 1) 'texte réduit de 1 caractère
            CollectLigne.Add i, y 'mémorise la ligne
        Next j
        For j = 1 To Len(x)
            car = LCase(Mid(x, j, 1))
            For k = 32 To 255
                c = LCase(Chr(k))
                If c <> car And k <> 178 And k <> 179 And k <> 185 Then
                    y = Left(x, j - 1) & c & Mid(x, j + 1) 'texte avec 1 caractère remplacé
                    CollectLigne.Add i, y 'mémorise la ligne
                End If
    Next k, j, i
    '---remplissage de resu---
    resu(1, 1) = "Ligne similaire"
    For i = 2 To UBound(tablo)
        resu(i, 1) = CollectLigne(LCase(tablo(i, 1)))
    Next i
    '---restitution---
    .AutoFilter: .AutoFilter 'si le tableau est filtré
    .Columns(2) = resu
End With
MsgBox "Durée des calculs " & Format(Timer - t, "0.00") & " secondes" & vbLf & vbLf _
    & "Une collection de " & Format(CollectLigne.Count, "#,##0") & " éléments a été étudiée..."
End Sub

Sub Compare()
Dim t, CollectLigne As New Collection, tablo, resu(), i&, x$, j%, y$, lig&, k%
t = Timer
On Error Resume Next
With [A1].CurrentRegion
    tablo = .Resize(, 2) 'matrice plus rapide, au moins 2 éléments
    ReDim resu(1 To UBound(tablo), 1 To 2)
    '---liste des textes sans doublon---
    For i = 2 To UBound(tablo)
        CollectLigne.Add i, LCase(tablo(i, 1)) 'mémorise la ligne
    Next i
    '---recherche des textes réduits ou remplacés---
    For i = 2 To UBound(tablo)
        x = LCase(tablo(i, 1))
        For j = 1 To Len(x)
            y = Left(x, j - 1) & Mid(x, j + 1) 'texte réduit de 1 caractère
            lig = 0
            lig = CollectLigne(y)
            If lig Then
                If InStr(", " & resu(i, 1) & ", ", ", " & lig & ", ") = 0 Then 'évite les doublons
                    If resu(i, 1) = "" Then resu(i, 1) = lig Else resu(i, 1) = resu(i, 1) & ", " & lig
                    If resu(i, 2) = "" Then resu(i, 2) = tablo(lig, 1) Else resu(i, 2) = resu(i, 2) & ", " & tablo(lig, 1)
                End If
                If InStr(", " & resu(lig, 1) & ", ", ", " & i & ", ") = 0 Then 'évite les doublons
                    If resu(lig, 1) = "" Then resu(lig, 1) = i Else resu(lig, 1) = resu(lig, 1) & ", " & i
                    If resu(lig, 2) = "" Then resu(lig, 2) = tablo(i, 1) Else resu(lig, 2) = resu(lig, 2) & ", " & tablo(i, 1)
                End If
            End If
        Next j
        For j = 1 To Len(x)
            For k = 32 To 255
                If k <> 178 And k <> 179 And k <> 185 Then
                    y = Left(x, j - 1) & LCase(Chr(k)) & Mid(x, j + 1) 'texte avec 1 caractère remplacé
                    lig = 0
                    lig = CollectLigne(y)
                    If lig And lig <> i Then
                        If InStr(", " & resu(i, 1) & ", ", ", " & lig & ", ") = 0 Then 'évite les doublons
                            If resu(i, 1) = "" Then resu(i, 1) = lig Else resu(i, 1) = resu(i, 1) & ", " & lig
                            If resu(i, 2) = "" Then resu(i, 2) = tablo(lig, 1) Else resu(i, 2) = resu(i, 2) & ", " & tablo(lig, 1)
                        End If
                        If InStr(", " & resu(lig, 1) & ", ", ", " & i & ", ") = 0 Then 'évite les doublons
                            If resu(lig, 1) = "" Then resu(lig, 1) = i Else resu(lig, 1) = resu(lig, 1) & ", " & i
                            If resu(lig, 2) = "" Then resu(lig, 2) = tablo(i, 1) Else resu(lig, 2) = resu(lig, 2) & ", " & tablo(i, 1)
                        End If
                    End If
                End If
    Next k, j, i
    '---restitution---
    .AutoFilter: .AutoFilter 'si le tableau est filtré
    resu(1, 1) = "Lignes similaires"
    resu(1, 2) = "Textes similaires"
    .Columns(2).Resize(, 2) = resu
End With
Columns.AutoFit 'ajustement largeurs
MsgBox "Durée des calculs " & Format(Timer - t, "0.00")
End Sub

Function percent_in_auther_ordre(s1, s2)
 Dim point As Double, p As Double, oz As Long
 tbl = Split(Replace(s1, "-", " "), " ")
    p = 100 / UBound(tbl)
    For oz = 0 To UBound(tbl)
        point = point + IIf(s2 Like "*" & tbl(oz) & "*", p, 0)
    Next
    percent_in_auther_ordre = point
End Function

Public Function similaire(ByVal s1 As String, ByVal s2 As String) As Double
'Calcul la similarité (de [0 à 1]) entre deux chaines d'après l'algorithme de Damerau-Levenshtein
'références : http://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance
'             http://mwh.geek.nz/2009/04/26/python-damerau-levenshtein-distance/
'             http://www-igm.univ-mlv.fr/~lecroq/seqcomp/node2.html
'Remarques  : Préparer les chaines car les comparaisons sont binaires : UCase(), Trim(),...
'Philben v1.0 - Free to Use
   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

Sub test()
    For i = 1 To 4
        pct = 0
        For a = 1 To 5
            x = percent_in_auther_ordre(Cells(i, 1).Text, Cells(a, 4).Text)
            If x = 100 Then
            Cells(i, 2) = Cells(a, 4).Address: Exit For
            Else
             x = similaire(Cells(i, 1).Text, Cells(a, 4).Text)
                      
                If x > pct Then pct = x: Add = Cells(a, 4).Address

                If x > 80 Then Cells(i, 2) = Cells(i, 2) & "  " & Add
            End If
        Next
        If Cells(i, 2) = "" Then Cells(i, 2) = Add
    Next

End Sub

Sub test()
chaine1 = "22224622"
chaine2 = "222246223"
MsgBox "test numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

Sub test2()
chaine1 = "toto mange des bannanes"
chaine2 = "toto mmange des bannanes"
MsgBox "test numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

Sub test3()
chaine1 = "toto mange des bannanes"
chaine2 = "toto croque des bannanes"
MsgBox "test numerique " & vbCrLf & "chaine 1=" & chaine1 & vbCrLf & "chaine 2=" & chaine2 & vbCrLf & "resultat = " & similaire(chaine1, chaine2) & "%"
End Sub

Sub Compare()
Dim t, d As Object, tablo, resu(), i&, x$, j%, y$, lig&, car$, k%, c$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
With [A1].CurrentRegion
    tablo = .Resize(, 2) 'matrice plus rapide, au moins 2 éléments
    ReDim resu(1 To UBound(tablo), 1 To 2)
    '---liste des textes sans doublon---
    For i = 2 To UBound(tablo)
        x = LCase(tablo(i, 1))
        If Not d.exists(x) Then d(x) = i 'mémorise la ligne
    Next i
    '---recherche des textes réduits ou remplacés---
    For i = 2 To UBound(tablo)
        x = LCase(tablo(i, 1))
        For j = 1 To Len(x)
            y = Left(x, j - 1) & Mid(x, j + 1) 'texte réduit de 1 caractère
            If d.exists(y) Then
                lig = d(y)
                If InStr(", " & resu(i, 1) & ", ", ", " & lig & ", ") = 0 Then 'évite les doublons
                    If resu(i, 1) = "" Then resu(i, 1) = lig Else resu(i, 1) = resu(i, 1) & ", " & lig
                    If resu(i, 2) = "" Then resu(i, 2) = tablo(lig, 1) Else resu(i, 2) = resu(i, 2) & ", " & tablo(lig, 1)
                End If
                If InStr(", " & resu(lig, 1) & ", ", ", " & i & ", ") = 0 Then 'évite les doublons
                    If resu(lig, 1) = "" Then resu(lig, 1) = i Else resu(lig, 1) = resu(lig, 1) & ", " & i
                    If resu(lig, 2) = "" Then resu(lig, 2) = tablo(i, 1) Else resu(lig, 2) = resu(lig, 2) & ", " & tablo(i, 1)
                End If
            End If
        Next j
        For j = 1 To Len(x)
            car = LCase(Mid(x, j, 1))
            For k = 32 To 255
                c = LCase(Chr(k))
                If c <> car And k <> 178 And k <> 179 And k <> 185 Then
                    y = Left(x, j - 1) & c & Mid(x, j + 1) 'texte avec 1 caractère remplacé
                    If d.exists(y) Then
                        lig = d(y)
                        If InStr(", " & resu(i, 1) & ", ", ", " & lig & ", ") = 0 Then 'évite les doublons
                            If resu(i, 1) = "" Then resu(i, 1) = lig Else resu(i, 1) = resu(i, 1) & ", " & lig
                            If resu(i, 2) = "" Then resu(i, 2) = tablo(lig, 1) Else resu(i, 2) = resu(i, 2) & ", " & tablo(lig, 1)
                        End If
                        If InStr(", " & resu(lig, 1) & ", ", ", " & i & ", ") = 0 Then 'évite les doublons
                            If resu(lig, 1) = "" Then resu(lig, 1) = i Else resu(lig, 1) = resu(lig, 1) & ", " & i
                            If resu(lig, 2) = "" Then resu(lig, 2) = tablo(i, 1) Else resu(lig, 2) = resu(lig, 2) & ", " & tablo(i, 1)
                        End If
                    End If
                End If
    Next k, j, i
    '---restitution---
    .AutoFilter: .AutoFilter 'si le tableau est filtré
    resu(1, 1) = "Lignes similaires"
    resu(1, 2) = "Textes similaires"
    .Columns(2).Resize(, 2) = resu
End With
Columns.AutoFit 'ajustement largeurs
MsgBox "Durée des calculs " & Format(Timer - t, "0.00")
End Sub