Recherche similitudes mais pas exactement entre deux colonnes

**Ysae68** · 26/10/2016, 10h18

Bonjour à tous,

Je viens vers vous pour un problème de gestion de données sur Excel, je ne sais pas trop si ce dont j'ai besoin est possible, je vous expose le truc. J'ai deux colonnes, contenant chacune une longue liste de noms de fichiers. J'aimerais pouvoir comparer ces deux colonnes pour repérer les fichiers qui s'y trouvent en double. Problème : tous ces noms de fichiers n'ont pas été saisis par la même personne, donc même si un fichier est en doublon dans les deux colonnes, le nom du fichier risque de ne pas être à 100% la même chaîne de caractères, suivant la nomenclature qu'a décidé la personne. Ca risque quand même d'être très approchant vu qu'il s'agirait du même fichier, mais pas exactement la même chose.

Y a t il donc possibilité de comparer les données des deux colonnes et de relever les similitudes en fonction d'un pourcentage ? Par exemple copier dans une troisième colonne tous les noms de fichiers avec une ressemblance de 80% ?

Comme dis, je n'ai aucune idée de si c'est faisable (j'ai déjà regardé sur Internet, mais rien en dehors de la façon de comparer en cherchant exactement la même chaîne de caractères), et si ça l'est, ça doit être assez technique donc je n'ai aucune idée de comment mettre ça en place.

Merci beaucoup d'avance à ceux qui se pencheront sur mon problème !

**patricktoulon** · 26/10/2016, 11h54

Bonjour
exemple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub test()
MsgBox ressemblance("comparer deux chaines", "camparér deus chaines") & "% de ressemblance"
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Public Function ressemblance(ByVal s1 As String, ByVal s2 As String) As Single
'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 Single, 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
    ressemblance = dls
End Function

a toi de décider après quel est le niveau de ressemblance acceptable pour accepter la chaine comme doublon

ajustement
pour une veracité plus importante un prétraitement était requis

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub test()
    MsgBox ressemblance("comparer deux chaine", "camparér deus chaine") & "% de ressemblance"
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Function pré_traitement(chaine As String)
    acc = Array("é", "è", "ê", "à", "ï")
    repl = Array("e", "e", "e", "a", "e", "i")
    For i = 0 To UBound(acc)
        chaine = Replace(chaine, acc(i), repl(i))
    Next
    chaine = UCase(chaine)
    pré_traitement = chaine
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
 
Public Function ressemblance(ByVal s1 As String, ByVal s2 As String) As Single
'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 Single, ac1() As Byte, ac2() As Byte
    s1 = pré_traitement(s1)
    s2 = pré_traitement(s2)
    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
    ressemblance = dls * 100
End Function

**Ysae68** · 26/10/2016, 15h23

Bonjour patricktoulon, et merci beaucoup pour tes réponses ! Le problème maintenant, c'est que ce code est vraiment très complexe...

Du coup je ne vois pas du tout comment l'adapter à mon simple fichier Excel, vu que je n'ai pas repéré de ligne pour définir les plages de cellules à traiter, et je ne me sens pas du tout capable de tripatouiller là dedans

**eriiic** · 27/10/2016, 01h11

Bonjour à tous,

Tu as l'addin de MS Fuzzy Lookup (recherche floue) qui pourrait t'intéresser : https://www.microsoft.com/en-us/down....aspx?id=15011
Puissant et beaucoup plus rapide qu'un code en vba (selon ton volume de comparaisons à faire).
Une présentation ici : http://www.emarketeur.fr/ressources/...-vieux-vlookup

Et si tu as besoin de faire une fonction plus personnalisée il faut utiliser l'algorithme sur la distance de Levenshtein donné par patrick.
eric

**unparia** · 27/10/2016, 08h44

Bonjour
Rien n'est à mon sens plus complexe à définir que la "ressemblance", en matière de textes.
Pour les uns, elle passe surtout par l'étude des caractères successifs
Pour d'autres, dont moi-même, par l'étude des phonèmes présents (et ce n'est pas simple). C'EST CE MECANISME, QUI EST A PRIVILEGIER, EN MATIERE DE COMPARAISON DE NOMS (le cas présent).
Pour d'autres, enfin, elle passe par l'étude de la "moelle" des principales propositions des textes (et c'est encore plus complexe, mais cela ne concerne pas le cas présent).

**Ysae68** · 27/10/2016, 14h50

Merci pour vos réponse à tous les deux. J'ai téléchargé Fuzzy Lookup, ça a l'air plutôt intéressant, je vais voir ce que ça donne

Recherche similitudes mais pas exactement entre deux colonnes [XL-2010]

Macros et VBA Excel

Partager

Partager