XL pour MAC Surligner les mots similaire dans une liste

[arico55]

Bonjour à tous,
J'ai besoin de votre aide.

J'ai une liste de 2700 mots clés.
certains d'entre sont assez similaires exemple
- chat > chats,
- sans abris > sans-abris (avec le tiret)

J'aimerais surligner tous les mots ayant des similitude (1 caractère près), est-ce possible ?
Si oui comment faire ?
Bonne soirée à tous.

 

[job75]

Il s'agit des cellules contenant des chiffres et je ne vois pas comment corriger cela.

Bon ce n'était pas évident mais j'ai fini par trouver.

Lors des remplacements il faut exclure les caractères de code 178 (exposant 2) 179 (exposant 3) et 185 (exposant 1).

Prenez donc ce fichier (4) avec la bonne macro :

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

 

[jmfmarques]

Bonjour Job75
D'autres surprises ne manqueront pas si la liste (thésaurus) concernée n'a pas été alimentée uniquement manuellement ou par affectation directe par vba de caractères ANSI , mais par copie à partir de sources différentes.
Et ce n'est pas tout.

 

[job75]

D'autres surprises ne manqueront pas

Avec la seule condition du post #1 je ne pense pas qu'il y aura encore des surprises si seuls les caractères ANSI sont utilisés.

Je n'ai pas traité les caractères de code 1 à 31 car ce serait une hérésie d'en mettre.

Mais si on en met alors modifier avec For k = 1 To 255.

 

[JHA]

Bonjour à tous,

Notre ami @arico55 nous a oublié semble-t-il et Job75 a fait un très gros travail

Attendons donc son retour pour connaître son avis.

JHA

 

[job75]

Un détail amusant ligne 652, chasseur => chaleur, non ce n'est pas une erreur.

VBA remplace les "ss" par le caractère allemand ß de code 223.

Ce n'est guère gênant mais bien sûr on peut exclure ce caractère comme au post #16.

 

[job75]

Bonjour le fil, le forum,

Il y a aussi en ligne 1657 thon => don, c'est dû au th converti en Þ (thorn) de code 222.

Mais voici dans ce fichier (5) une utilisation bien meilleure de la collection :

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

La macro s'exécute chez moi en 10,8 secondes.

A+

 

[patricktoulon]

bonjour le fil

je dépoussière
d'abords calcul pourcentage en fonction des mot dans le désordre

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

ensuite Calcul la similarité via la distance entre les chaines

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

exemple d'utilisation

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

visuel démo

on peut utiliser aussi seulement"similaire"

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

 

[job75]

Voici dans le fichier joint la même solution avec le Dictionary :

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

La macro s'exécute chez moi en 6,8 secondes.

Par rapport à la collection on constate des résultats différents sur 6 lignes :

- ligne 652 chasseur => chaleur (à cause du caractère ß de code 223)

- ligne 857 don => thon (à cause du caractère Þ de code 222)

- ligne 1150 oeil => ail (à cause du caractère œ de code 156 )

- ligne 1349 chaleur => chasseur (à cause du caractère ß de code 223)

- ligne 1428 ail => oeil (à cause du caractère œ de code 156)

- ligne 1657 thon => don (à cause du caractère Þ de code 222)