XL pour MAC Surligner les mots similaire dans une liste

=NB.SI($A$2:$A$2725;$A2&"*")>1

Sub Compare()
Dim CollectLigne As New Collection, tablo, resu(), i&, x$, j%, y$
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 de 1 caractère---
    For i = 2 To UBound(tablo)
        x = tablo(i, 1)
        For j = 1 To Len(x)
            y = Left(x, j - 1) & Mid(x, j + 1) 'texte réduit
            CollectLigne.Add i, y 'mémorise la ligne
    Next j, i
    '---remplissage de resu---
    resu(1, 1) = "Ligne similaire"
    For i = 2 To UBound(tablo)
        resu(i, 1) = CollectLigne(tablo(i, 1))
    Next i
    '---restitution---
    .AutoFilter: .AutoFilter 'si le tableau est filtré
    .Columns(2) = resu
End With
End Sub

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 = 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 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(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