Comparaison de chaînes de texte similaires dans Excel

J'essaie actuellement de réconcilier les champs «Nom» de deux sources de données distinctes. J'ai un certain nombre de noms qui ne correspondent pas exactement mais qui sont suffisamment proches pour être considérés comme identiques (exemples ci-dessous). Avez-vous des idées pour améliorer le nombre de correspondances automatiques? J'élimine déjà les initiales du milieu des critères de correspondance.

Formule de match actuelle:

=IFERROR(IF(LEFT(SYSTEM A,IF(ISERROR(SEARCH(" ",SYSTEM A)),LEN(SYSTEM A),SEARCH(" ",SYSTEM A)-1))=LEFT(SYSTEM B,IF(ISERROR(SEARCH(" ",SYSTEM B)),LEN(SYSTEM B),SEARCH(" ",SYSTEM B)-1)),"",IF(LEFT(SYSTEM A,FIND(",",SYSTEM A))=LEFT(SYSTEM B,FIND(",",SYSTEM B)),"Last Name Match","RESEARCH")),"RESEARCH")

Vous pouvez envisager d'utiliser le complément Microsoft Fuzzy Lookup .

Du site MS:

Aperçu

Le complément de recherche floue pour Excel a été développé par Microsoft Research et effectue une correspondance floue des données textuelles dans Microsoft Excel. Il peut être utilisé pour identifier des lignes en double floues dans une seule table ou pour joindre des lignes similaires floues entre deux tables différentes. La correspondance est robuste à une grande variété d'erreurs, y compris les fautes d'orthographe, les abréviations, les synonymes et les données ajoutées / manquantes. Par exemple, il pourrait détecter que les lignes «M. Andrew Hill »,« Hill, Andrew R. » et "Andy Hill" se réfèrent tous à la même entité sous-jacente, renvoyant un score de similitude avec chaque match. Bien que la configuration par défaut fonctionne bien pour une grande variété de données textuelles, telles que les noms de produits ou les adresses des clients, la correspondance peut également être personnalisée pour des domaines ou des langues spécifiques.

Je chercherais à utiliser cette liste (section anglaise uniquement) pour aider à éliminer les raccourcis courants.

De plus, vous voudrez peut-être envisager d'utiliser une fonction qui vous dira, en termes exacts, comment "fermer" deux chaînes sont. Le code suivant est venu d' ici et merci à smirkingman .

Option Explicit
Public Function Levenshtein(s1 As String, s2 As String)

Dim i As Integer
Dim j As Integer
Dim l1 As Integer
Dim l2 As Integer
Dim d() As Integer
Dim min1 As Integer
Dim min2 As Integer

l1 = Len(s1)
l2 = Len(s2)
ReDim d(l1, l2)
For i = 0 To l1
    d(i, 0) = i
Next
For j = 0 To l2
    d(0, j) = j
Next
For i = 1 To l1
    For j = 1 To l2
        If Mid(s1, i, 1) = Mid(s2, j, 1) Then
            d(i, j) = d(i - 1, j - 1)
        Else
            min1 = d(i - 1, j) + 1
            min2 = d(i, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            min2 = d(i - 1, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            d(i, j) = min1
        End If
    Next
Next
Levenshtein = d(l1, l2)
End Function

Ce que cela va faire est de vous dire combien d'insertions et de suppressions doivent être effectuées sur une chaîne pour accéder à l'autre. J'essaierais de garder ce nombre bas (et les noms de famille devraient être exacts).

J'ai une (longue) formule que vous pouvez utiliser. Ce n'est pas aussi bien affiné que ceux ci-dessus - et ne fonctionne que pour le nom de famille plutôt que pour un nom complet - mais vous pourriez le trouver utile.

Donc, si vous avez une ligne d'en-tête et que vous souhaitez comparer A2avec B2, placez-la dans n'importe quelle autre cellule de cette ligne (par exemple, C2) et copiez jusqu'à la fin.

= IF (A2 = B2, "EXACT", IF (SUBSTITUTE (A2, "-", "") = SUBSTITUTE (B2, "-", ""), "Hyphen", IF (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUBSTITUTE (A2, B2, "")), "Chaîne entière", IF (MID (A2,1,1) = MID (B2,1,1), 1, 0) + IF (MID (A2,2,1) = MID (B2,2,1), 1,0) + IF (MID (A2,3,1) = MID (B2,3,1), 1, 0) + IF (MID (A2, LEN (A2), 1) = MID (B2, LEN (B2), 1), 1,0) + IF (MID (A2, LEN (A2) -1,1) = MID (B2, LEN (B2) -1,1), 1,0) + IF (MID (A2, LEN (A2) -2,1) = MID (B2, LEN (B2) -2,1), 1 , 0) & "°"), IF (LEN (B2)> LEN (SUBSTITUTE (B2, A2, "")), "Whole String", IF (MID (A2,1,1) = MID (B2,1) , 1), 1,0) + IF (MID (A2,2,1) = MID (B2,2,1), 1,0) + IF (MID (A2,3,1) = MID (B2,3 , 1), 1,0) + IF (MID (A2, LEN (A2), 1) = MID (B2, LEN (B2), 1), 1,0) + IF (MID (A2, LEN (A2) -1,1) = MID (B2, LEN (B2) -1,1), 1,0) + IF (MID (A2, LEN (A2) -2,1) = MID (B2, LEN (B2) - 2,1), 1,0) et "°"))))

Cela reviendra:

• EXACT - si c'est une correspondance exacte
• Trait d'union - s'il s'agit d'une paire de noms à double barillet mais qu'il y a un trait d'union et l'autre un espace
• Chaîne entière - si tous les noms de famille font partie de l'autre (par exemple, si un Smith est devenu un French-Smith)

Après cela, il vous donnera un degré de 0 ° à 6 ° en fonction du nombre de points de comparaison entre les deux. (c.-à-d. 6 ° se compare mieux).

Comme je le dis un peu rude et prêt, mais j'espère que cela vous amènera à peu près au bon terrain de jeu.

Cherchait quelque chose de similaire. J'ai trouvé le code ci-dessous. J'espère que cela aide le prochain utilisateur qui vient à cette question

Renvoie 91% pour Abracadabra / Abrakadabra, 75% pour Hollywood Street / Hollyhood Str, 62% pour Florence / France et 0 pour Disneyland

Je dirais que c'est assez proche de ce que tu voulais :)

Public Function Similarity(ByVal String1 As String, _
    ByVal String2 As String, _
    Optional ByRef RetMatch As String, _
    Optional min_match = 1) As Single
Dim b1() As Byte, b2() As Byte
Dim lngLen1 As Long, lngLen2 As Long
Dim lngResult As Long

If UCase(String1) = UCase(String2) Then
    Similarity = 1
Else:
    lngLen1 = Len(String1)
    lngLen2 = Len(String2)
    If (lngLen1 = 0) Or (lngLen2 = 0) Then
        Similarity = 0
    Else:
        b1() = StrConv(UCase(String1), vbFromUnicode)
        b2() = StrConv(UCase(String2), vbFromUnicode)
        lngResult = Similarity_sub(0, lngLen1 - 1, _
        0, lngLen2 - 1, _
        b1, b2, _
        String1, _
        RetMatch, _
        min_match)
        Erase b1
        Erase b2
        If lngLen1 >= lngLen2 Then
            Similarity = lngResult / lngLen1
        Else
            Similarity = lngResult / lngLen2
        End If
    End If
End If

End Function

Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _
                                ByVal start2 As Long, ByVal end2 As Long, _
                                ByRef b1() As Byte, ByRef b2() As Byte, _
                                ByVal FirstString As String, _
                                ByRef RetMatch As String, _
                                ByVal min_match As Long, _
                                Optional recur_level As Integer = 0) As Long
'* CALLED BY: Similarity *(RECURSIVE)

Dim lngCurr1 As Long, lngCurr2 As Long
Dim lngMatchAt1 As Long, lngMatchAt2 As Long
Dim I As Long
Dim lngLongestMatch As Long, lngLocalLongestMatch As Long
Dim strRetMatch1 As String, strRetMatch2 As String

If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _
Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then
    Exit Function '(exit if start/end is out of string, or length is too short)
End If

For lngCurr1 = start1 To end1
    For lngCurr2 = start2 To end2
        I = 0
        Do Until b1(lngCurr1 + I) <> b2(lngCurr2 + I)
            I = I + 1
            If I > lngLongestMatch Then
                lngMatchAt1 = lngCurr1
                lngMatchAt2 = lngCurr2
                lngLongestMatch = I
            End If
            If (lngCurr1 + I) > end1 Or (lngCurr2 + I) > end2 Then Exit Do
        Loop
    Next lngCurr2
Next lngCurr1

If lngLongestMatch < min_match Then Exit Function

lngLocalLongestMatch = lngLongestMatch
RetMatch = ""

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(start1, lngMatchAt1 - 1, _
start2, lngMatchAt2 - 1, _
b1, b2, _
FirstString, _
strRetMatch1, _
min_match, _
recur_level + 1)
If strRetMatch1 <> "" Then
    RetMatch = RetMatch & strRetMatch1 & "*"
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _
    , "*", "")
End If


RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch)


lngLongestMatch = lngLongestMatch _
+ Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _
lngMatchAt2 + lngLocalLongestMatch, end2, _
b1, b2, _
FirstString, _
strRetMatch2, _
min_match, _
recur_level + 1)

If strRetMatch2 <> "" Then
    RetMatch = RetMatch & "*" & strRetMatch2
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And ((lngMatchAt1 + lngLocalLongestMatch < end1) _
    Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _
    , "*", "")
End If

Similarity_sub = lngLongestMatch

End Function

Vous pouvez utiliser la fonction de similarité (pwrSIMILARITY) pour comparer les chaînes et obtenir une correspondance en pourcentage des deux. Vous pouvez le rendre sensible à la casse ou non. Vous devrez décider quel pourcentage d'une correspondance est "assez proche" de vos besoins.

Il y a une page de référence à http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsimilarity/ .

Mais cela fonctionne assez bien pour comparer le texte de la colonne A à la colonne B.

Bien que ma solution ne permette pas d'identifier des chaînes très différentes, elle est utile pour une correspondance partielle (correspondance de sous-chaîne), par exemple "ceci est une chaîne" et "une chaîne" résultera en "correspondance":

ajoutez simplement "*" avant et après la chaîne à rechercher dans le tableau.

Formule habituelle:

• vlookup (A1, B1: B10,1,0)
• cerca.vert (A1; B1: B10; 1; 0)

devient

• vlookup ("*" & A1 & "*", B1: B10; 1,0)
• cerca.vert ("*" & A1 & "*"; B1: B10; 1; 0)

"&" est la "version courte" pour concaténer ()

Cette colonne d'analyse de code a et la colonne b, si elle trouve une similitude dans les deux colonnes, elle s'affiche en jaune. Vous pouvez utiliser un filtre de couleur pour obtenir la valeur finale. Je n'ai pas ajouté cette partie dans le code.

Sub item_difference()

Range("A1").Select

last_row_all = Range("A65536").End(xlUp).Row
last_row_new = Range("B65536").End(xlUp).Row

Range("A1:B" & last_row_new).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

For i = 1 To last_row_new
For j = 1 To last_row_all

If Range("A" & i).Value = Range("A" & j).Value Then

Range("A" & i & ":B" & i).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
  .PatternTintAndShade = 0
End With

End If
Next j
Next i
End Sub