Porównywanie podobnych ciągów tekstowych w programie Excel

Obecnie próbuję uzgodnić pola „Nazwa” z dwóch oddzielnych źródeł danych. Mam wiele nazw, które nie pasują dokładnie, ale są wystarczająco blisko, aby można je było uznać za dopasowane (przykłady poniżej). Czy masz jakieś pomysły, jak mogę poprawić liczbę automatycznych dopasowań? Już eliminuję środkowe inicjały z kryteriów meczu.

Aktualny wzór dopasowania:

=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")

Możesz rozważyć użycie Microsoft Fuzzy Lookup Addin .

Z witryny MS:

Przegląd

Dodatek Fuzzy Lookup dla programu Excel został opracowany przez Microsoft Research i wykonuje rozmyte dopasowanie danych tekstowych w programie Microsoft Excel. Można go użyć do identyfikacji rozmytych duplikatów wierszy w jednej tabeli lub rozmytego łączenia podobnych wierszy między dwiema różnymi tabelami. Dopasowywanie jest odporne na wiele różnych błędów, w tym na błędy ortograficzne, skróty, synonimy i dodane / brakujące dane. Na przykład może wykryć, że wiersze „Mr. Andrew Hill ”,„ Hill, Andrew R. ” a „Andy Hill” odnoszą się do tej samej jednostki podstawowej, zwracając wynik podobieństwa wraz z każdym dopasowaniem. Chociaż domyślna konfiguracja działa dobrze dla szerokiej gamy danych tekstowych, takich jak nazwy produktów lub adresy klientów, dopasowanie można również dostosować do określonych domen lub języków.

Chciałbym skorzystać z tej listy (tylko sekcja angielska), aby pomóc wyeliminować typowe skróty.

Ponadto warto rozważyć użycie funkcji, która dokładnie powie ci, jak „zamknąć” dwa ciągi znaków. Poniższy kod przyszedł stąd i dzięki 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

Pozwoli to powiedzieć, ile wstawień i usunięć należy wykonać w jednym ciągu, aby przejść do drugiego. Spróbowałbym utrzymać ten numer na niskim poziomie (a nazwiska powinny być dokładne).

Mam (długą) formułę, której możesz użyć. Nie jest tak wyostrzony jak powyższe - i działa tylko na nazwisko, a nie na imię i nazwisko - ale może się przydać.

Więc jeśli masz wiersz nagłówka i chcesz porównać A2z B2umieść to w każdej innej komórki w tym wierszu (np C2) i skopiować w dół do końca.

= JEŻELI (A2 = B2, „DOKŁADNIE”, JEŻELI (SUBSTITUTE (A2, „-”, „”)) = SUBSTITUTE (B2, „-”, „”), „Łącznik”, JEŻELI (LEN (A2)> LEN ( B2), JEŻELI (LEN (A2)> LEN (SUBSTITUTE (A2, B2, „”)), „Cały ciąg”, JEŻELI (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) i „°”), JEŻELI (LEN (B2)> LEN (SUBSTITUTE (B2, A2, „”)), „Cały ciąg”, JEŻELI (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) i „°”))))

Zwróci to:

• DOKŁADNIE - jeśli jest to dokładne dopasowanie
• Łącznik - jeśli jest to para nazw z podwójną lufą, ale włączona ma myślnik, a druga spację
• Cały ciąg znaków - jeśli całe jedno nazwisko jest częścią drugiego (np. Jeśli Smith stał się Francuzem)

Następnie da ci stopień od 0 ° do 6 ° w zależności od liczby punktów porównania między nimi. (tj. 6 ° porównuje lepiej).

Jak mówię, nieco szorstki i gotowy, ale mam nadzieję, że dostaniesz mniej więcej odpowiedni bal-park.

Szukał czegoś podobnego. Znalazłem kod poniżej. Mam nadzieję, że pomoże to następnemu użytkownikowi, który przejdzie na to pytanie

Zwraca 91% dla Abracadabra / Abrakadabra, 75% dla Hollywood Street / Hollyhood Str, 62% dla Florencji / Francji i 0 dla Disneylandu

Powiedziałbym, że jest wystarczająco blisko tego, czego chciałeś :)

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

Możesz użyć funkcji podobieństwa (pwrSIMILARITY), aby porównać ciągi i uzyskać procentowe dopasowanie tych dwóch. Możesz ustawić rozróżnianie wielkości liter lub nie. Musisz zdecydować, jaki procent dopasowania jest „wystarczająco blisko” do twoich potrzeb.

Istnieje strona referencyjna pod adresem http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsimilarity/ .

Ale działa całkiem dobrze do porównywania tekstu w kolumnie A z kolumną B.

Chociaż moje rozwiązanie nie pozwala na identyfikację bardzo różnych ciągów, jest użyteczne przy częściowym dopasowaniu (dopasowaniu podciągu), np. „To ciąg”, a „ciąg” spowoduje „dopasowanie”:

po prostu dodaj „*” przed i po ciągu, aby wyszukać w tabeli.

Zwykła formuła:

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

staje się

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

„&” to „krótka wersja” dla concatenate ()

Ten kod skanuje kolumny a i kolumnę b, jeśli znajdzie jakieś podobieństwo w obu kolumnach, wyświetli się na żółto. Możesz użyć filtra kolorów, aby uzyskać końcową wartość. Nie dodałem tej części do kodu.

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