XL 2016 pourcentage de ressemblance entre deux chaines de caracteres excel

Youcho

XLDnaute Nouveau
Bonjour,

j'ai en face un problème de comparer deux valeurs textes ,qui ont un taux de ressemblance élevé mais Excel malheureusement nous donne la possibilité de comparer que les valeurs identiques à 100% ,vous trouvez ci après un échantillon de mon fichier :

Nom&prénom base de données locale
Nom&prénom base de données externe
Pourcentage de ressemblance
KarimustaphaKarimustafala différence c'est juste "f" au lieu de "ph" donc c'est le même
SimonesaraSimonesarahidem c'est juste une faute de frappe
CristophegabrielCristphegabriell
idem c'est juste une faute de frappe

Merci pour votre collaboration .
 

Modeste geedee

XLDnaute Barbatruc
Bonsour®
j'ai en face un problème de comparer deux valeurs textes ,qui ont un taux de ressemblance élevé mais Excel malheureusement nous donne la possibilité de comparer que les valeurs identiques à 100% ,vous trouvez ci après un échantillon de mon fichier :

Nom&prénom base de données locale
Nom&prénom base de données externe
Pourcentage de ressemblance
KarimustaphaKarimustafala différence c'est juste "f" au lieu de "ph" donc c'est le même
SimonesaraSimonesarahidem c'est juste une faute de frappe
CristophegabrielCristphegabriell
idem c'est juste une faute de frappe
il existe une fonction grossière permettant une approche simple de cette problématique ...
  • ne détecte pas l'inversion nom prénom !!!
  • principalement basée sur les consonnes
1575461049304.png

Soundex
L'algorithme utilisé pour transformer des noms, de telle sorte que deux noms phonétiquement voisins aient même valeur, est SOUNDEX, dont une description précise est donnée dans l'ouvrage de D.Knuth, The Art of Computer Programming, Vol.3, Sorting and Searching. – Addison Wesley, 1973, page 392.
Cette fonction va calculer un code en quatre caractères (maximum) de façon à regrouper des mots de « même » consonance. Elle sera utilisée pour rechercher des valeurs dans une liste ou base de données. C'est ainsi que les mots «mètre», «mettre», «maître», ... auront le même code. Cet algorithme est d'ailleurs utilisé en généalogie pour retrouver les noms qui auraient subi une transformation due entre autres à une faute de recopie.

Voici les idées sur lesquelles s'appuie l'algorithme :

  • les voyelles et Y contribuent moins pour la consonance d'un mot que les consonnes. Elles seront donc supprimées sauf celle en position initiale;
  • les lettres H, W ont aussi une contribution minimale et seront donc supprimées sauf celle en position initiale;
  • les consonnes redoublées comme NN, SS et MM ou les lettres qui ont la même prononciation peuvent être réduites à une seule occurrence;
VB:
Function Soundex(s) As String
    Dim i As Integer, s1 As String
'   Suppression des espaces et     transformation du mot en majuscule
    s = UCase(Trim(s))
    s1 = Left(s, 1)
    Select Case True
        Case s1 Like "[ÀÂÄ]": s1 = "A"
        Case s1 Like "[ÉÈÊË]": s1 = "E"
        Case s1 Like "[ÎÏ]": s1 = "I"
        Case s1 Like "[ÔÖ]": s1 = "O"
        Case s1 Like "[ÙÛÜ]": s1 = "U"
        Case s1 = "Ç": s1 = "C"
    End Select
    s = s1 & Mid(s, 2)
'   Calcul du soundex'   Premier caractère
    Soundex = Left(s, 1)
'   Autres caractères
    For i = 2 To Len(s)
        If Len(Soundex) = 4 Then ' ********************possibilité d'allonger la chaîne de ressemblance
            Exit Function
        Else
            s1 = Mid(s, i, 1)
            Select Case True
                Case s1 Like "[BP]": s1 = "1"
                Case s1 Like "[CKQ]": s1 = "2"
                Case s1 Like "[DT]": s1 = "3"
                Case s1 = "L": s1 = "4"
                Case s1 Like "[MN]": s1 = "5"
                Case s1 = "R": s1 = "6"
                Case s1 Like "[GJ]": s1 = "7"
                Case s1 Like "[XZS]": s1 = "8"
                Case s1 Like "[FV]": s1 = "9"
                Case Else
                    s1 = ""
            End Select
'           Elimination des doubles
            If s1 <> "" Then
                If s1 <> Right(Soundex, 1) Then
                    Soundex = Soundex & s1
                End If
            End If
        End If
    Next i
End Function
 

patricktoulon

XLDnaute Barbatruc
Bonsoir a tous
avez vous entendu parler de l’algorithme de levenshtein
basé la dessus
reste a l'utilisateur de decider le pourcentage acceptable


VB:
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
    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

pour l’occase voila un exemple lancer la sub test et regarder les address en colonne "B"
 

Pièces jointes

  • similaire 2.xls
    42 KB · Affichages: 111

patricktoulon

XLDnaute Barbatruc
re
et oui je suis parti dans des algo fou
ok je rajouterais le replace des caractères spéciaux c'est pas con du tout
et en effet mieux vaut laisser les deux fonction séparées
car je me sert de l'algo pour vérifier l'orthographe aussi
donc y a tout bon je prends ;)

merci Modeste geedee
avec ca youcho a tout ;)
 

Sirfalas

XLDnaute Nouveau
Bonsour®
il existe une fonction grossière permettant une approche simple de cette problématique ...
  • ne détecte pas l'inversion nom prénom !!!
  • principalement basée sur les consonnes
Regarde la pièce jointe 1047974
VB:
Function Soundex(s) As String
    Dim i As Integer, s1 As String
'   Suppression des espaces et     transformation du mot en majuscule
    s = UCase(Trim(s))
    s1 = Left(s, 1)
    Select Case True
        Case s1 Like "[ÀÂÄ]": s1 = "A"
        Case s1 Like "[ÉÈÊË]": s1 = "E"
        Case s1 Like "[ÎÏ]": s1 = "I"
        Case s1 Like "[ÔÖ]": s1 = "O"
        Case s1 Like "[ÙÛÜ]": s1 = "U"
        Case s1 = "Ç": s1 = "C"
    End Select
    s = s1 & Mid(s, 2)
'   Calcul du soundex'   Premier caractère
    Soundex = Left(s, 1)
'   Autres caractères
    For i = 2 To Len(s)
        If Len(Soundex) = 4 Then ' ********************possibilité d'allonger la chaîne de ressemblance
            Exit Function
        Else
            s1 = Mid(s, i, 1)
            Select Case True
                Case s1 Like "[BP]": s1 = "1"
                Case s1 Like "[CKQ]": s1 = "2"
                Case s1 Like "[DT]": s1 = "3"
                Case s1 = "L": s1 = "4"
                Case s1 Like "[MN]": s1 = "5"
                Case s1 = "R": s1 = "6"
                Case s1 Like "[GJ]": s1 = "7"
                Case s1 Like "[XZS]": s1 = "8"
                Case s1 Like "[FV]": s1 = "9"
                Case Else
                    s1 = ""
            End Select
'           Elimination des doubles
            If s1 <> "" Then
                If s1 <> Right(Soundex, 1) Then
                    Soundex = Soundex & s1
                End If
            End If
        End If
    Next i
End Function
Bonsoir,

Ce VBA m'intéresse énormément mais n'ayant pas assez de connaissance avec le développeur Excel, je n'arrive pas à le faire fonctionner...
J'ai copié-coller la fonction dans Microsoft viusal basic mais quand je la lance, j'ai un carré qui s'affiche avec écrit "UseForm 1" et je ne peux plus rien faire.

Vous avez quelque chose à me proposer ?

Merci par avance.
 

Discussions similaires

Statistiques des forums

Discussions
312 803
Messages
2 092 256
Membres
105 318
dernier inscrit
alberic63