Microsoft 365 Nombre de caractères uniques communs entre 2 cellules

[jipi06]

Bonjour à toutes et tous

Je dispose de 2 bases : 1 où on trouve un référentiel de noms de chevaux (Base B : 1500 noms) et une base (Base A : 1800 lignes) où a été saisi le nom et d'autres données, sans recours à des listes de validation ...résultat : la liste saisie comporte beaucoup d'erreurs d'orthographe ...
Je dois donc travailler sur la recherche d'erreurs entre les 2 bases.
Le but étant de déterminer dans la liste A (liste de saisie) le nom le plus proche du nom inscrit au référentiel de la Base B.
J'ai essayé de faire une formule qui cherche le nom de référence en comparant à Gauche puis à Droite des noms saisis en testant de 3 à 7 caractères, mais le résultat n'est pas satisfaisant et lourd à gérer.
ex pour recherche Gauche pour 3 caractères :
SI(SOMMEPROD(--ESTNUM(CHERCHE(STXT(B2;LIGNE(INDIRECT("1:"&(NBCAR(B2)-1)));3);INDEX(BAseTest;EQUIV("*"&GAUCHE(B2;3)&"*";BAseTest;0)))))=0;"";
(SI(SOMMEPROD(--ESTNUM(CHERCHE(STXT(B2;LIGNE(INDIRECT("1:"&(NBCAR(B2)-1)));3);INDEX(BAseTest;EQUIV("*"&GAUCHE(B2;3)&"*";BAseTest;0)))))>0;
INDEX(BAseTest;EQUIV("*"&GAUCHE(B2;3)&"*";BAseTest;0))&"-";"")))

J'aurai préféré un code VBA mais je n'ai pas réussi..

Je mets un extrait du fichier et le résultat que j'attends.

Merci beaucoup de votre aide.

jipi06

 

[chris]

Bonjour

PowerQuery permet des comparaisons approximative avec un taux réglable

Voir si cela convient ou adapter le taux

 

[jipi06]

Merci de votre réponse. Je préfèrerai faire avec du VBA, je n'ai pas encore plongé dans PQuery...

 

[patricktoulon]

Bonjour

la liste saisie comporte beaucoup d'erreurs d'orthographe ...

déjà là on a un soucis
comment comparer "fleur de lyce" et "fleur de lices" avec une comparaison classique de caractères
c'est impossible
par contre j'ai bien une fonction basé sur algorithme de Levenshtein
base sur la distance entre deux chaines en ajout suppression et substitution
reste que cette appréciation est humaine donc le paramètre de pourcentage est humain
cela dit ou un simple algo trouverait pas de "l'eau de la marre" dans "l'eau de la mer" cet algo lui pointerais la chaîne avec un certain pourcentage de similarité

en voici une petites demo
autant dire que les fautes d’orthographe tel que

1. le pluriel
2. une lettre tapée malencontreusement en double
3. une lettre substituée par une autre

c'est du p(y)pi de chat pour cet algo MAIS!!! le paramétrage (je le répète)reste une appréciation humain

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


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
'Remarques  : Préparer les chaines car les comparaisons sont binaires : UCase(), Trim(),...
   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

 

[patricktoulon]

re
un ans plus tard j'avais ajouté l'option bonnet blanc blanc bonnet

Sub testq()
    MsgBox similaire("blanc bonnet ou bonnet blanc", "bonnet blanc ou blanc bonnet") & "%"
End Sub


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
    Dim px As Double, p As Double, oz As Long
    If InStr(s1, " ") > 0 Then
        tbl = Split(Replace(s1, "-", " "), " ")
        p = 100 / UBound(tbl)
        For oz = 0 To UBound(tbl): px = px + IIf(s2 Like "*" & tbl(oz) & "*", p, 0): Next
        If px >= 100 Then similaire = 100: Exit Function
     Else
        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 If
End Function

 

[jipi06]

Bonjour,
le résultat est techniquement bon si je l'utilise la comparaison de cellule à cellule. Dans mon cas, je dois comparer une cellule avec l'ensemble d'une plage de 1500 lignes.

Est ce possible d'afficher le résultat dans une cellule adjacente à la cellule recherchée le ou les Noms trouvés avec leur Tx de rapprochement ? Avec un taux de rapprochement mini de 40 par ex (après je pourrai affiner le taux) et l'augmenter pour ne pas avoir trop d'incohérences

Base avec fautes	Base Référence
ARADOS	ARADOS(100)
LADY ANNOUCHE	LADY ANNOUCHE(93)
SYBELLE	SIBELLE(75)
OPALE	PALMYRE(43)

 

[jipi06]

patricktoulon j'ai utilisé un de tes anciens post qui ressemble à mon problème.
j'ai essayé de l'utiliser mais j'ai des résultats qui ne correspondent pas complètement ou que je ne comprends pas..... Je met en pj le fichier Similaire 22 avec qq commentaires que j'ai légèrement modifié.

 

[patricktoulon]

re
pour commencer tu utilise la version avec les deux fonctions alors que je viens de te donner la derniere version qui merge la percent et similaire en une seule
après je vois dans ton commentaire qu'il y devrait y avoir une correspondance
et a vue d' œil sauf si mes lunettes me jouent des tours il n'y en a pas pour OPALLEO
comme lady gaga d'ailleurs il ne devrait pas en avoir car le pourcentage de similitude est bien trop faible
ensuite je vois que tu utilise txcor comme variable limite et elle n'est pas instruite donc elle vaut 0
bref c'est pas gagné hein
et comble de l'inutile je vois ensuite
ceci
If Cells(i, 2) = "" Then Cells(i, 2) = ""
je traduit au cas ou tu n'aurais pas compris
si la cellule(ligne i, colonne2) est vide alors la cellule( ligne i, colonne2) est vide

le pinard c'est un verre ballon par jour ; plus c'est mettre sa santé en danger

 

[jipi06]

OK patricktoulon j'ai remis ton code avec la v2 du code similaire.
Je vais tester le code sur le fichier réel.
Merci

 

[patricktoulon]

re
tiens je l'ai un peu amélioré dans le sens de ton utilisation
plus tu baisse ta cellule taux plus tu aura des correspondances a un % (plus ou moins faible)
perso le minimum c'est 85% en dessous ça n'a pas vraiment de sens mais bon
allez change tout le code dans le module pour celui ci

Sub Compar()
'patricktoulon -https://www.excel-downloads.com/members/patricktoulon.167882/
    Dim txCor&, ptc#, x#
    txCor = Val(Range("E2").Value)
    Range("B2:B37").Select
    Selection.ClearContents
    For i = 2 To 15
        pct = 0: Add = "": x = 0
        For a = 2 To 6
            x = Round(similaire(Cells(i, 1).Text, Cells(a, 4).Text), 2)
            If x > Val(Cells(i, 2)) And x > txCor Then Cells(i, 2) = x & " %  " & Cells(a, 4).Address(0, 0) & "(" & Cells(a, 4) & ")"
            If x = 100 Then Exit For
        Next
    Next
End Sub


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
    Dim px As Double, p As Double, oz As Long

    tbl = Split(Replace(s1, "-", " "), " ")
    If IsArray(tbl) Then
        If UBound(tbl) > 1 Then 'on ne teste le[B] other ordre[/B] que si il y a plus de 2 mots 
            p = 100 / UBound(tbl)
            For oz = 0 To UBound(tbl): px = px + IIf(s2 Like "*" & tbl(oz) & "*", p, 0): Next
            If px >= 100 Then similaire = 100: Exit Function' si il y a tout  on sort a 100%
        End If
    End If
   'sinon on procède  à l’examen en bits 
 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

on voit bien dans cette capture que quand on descend le niveau trop bas ça n'a plus de sens , bien qu'en terme d'analyse binaire ça soit exact et en niveau min de 80 on a une réponse fiable
voilà voilà

 

[jipi06]

Salut
Nickel. Ca fonctionne très bien sur la base finale. Merci beaucoup.
A+
jipi06