Сравнение похожих текстовых строк в Excel

В настоящее время я пытаюсь согласовать поля «Имя» из двух отдельных источников данных. У меня есть несколько имен, которые не являются точным соответствием, но достаточно близки, чтобы считаться совпадающими (примеры ниже). У вас есть идеи, как я могу улучшить количество автоматических матчей? Я уже исключаю средние инициалы из критериев соответствия.

Формула текущего матча:

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

Вы можете рассмотреть возможность использования надстройки Microsoft Fuzzy Lookup .

С сайта MS:

обзор

Надстройка нечеткого поиска для Excel была разработана Microsoft Research и выполняет нечеткое сопоставление текстовых данных в Microsoft Excel. Его можно использовать для идентификации нечетких дублирующихся строк в одной таблице или для нечеткого соединения похожих строк между двумя разными таблицами. Сопоставление устойчиво к множеству ошибок, включая орфографические ошибки, сокращения, синонимы и добавленные / отсутствующие данные. Например, он может обнаружить, что строки «Mr. Эндрю Хилл »,« Хилл, Эндрю Р. » и «Энди Хилл» относится к одному и тому же базовому объекту, возвращая оценку сходства вместе с каждым совпадением. Хотя конфигурация по умолчанию работает хорошо для широкого спектра текстовых данных, таких как названия продуктов или адреса клиентов, сопоставление также может быть настроено для конкретных доменов или языков.

Я хотел бы использовать этот список (только на английском языке), чтобы отсеять обычные сокращения.

Кроме того, вы можете рассмотреть возможность использования функции, которая точно скажет вам, насколько «близки» две строки. Следующий код пришел отсюда и благодаря ухмылке .

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

Это скажет вам, сколько вставок и удалений нужно сделать с одной строкой, чтобы перейти к другой. Я бы попытался сохранить это число низким (и фамилии должны быть точными).

У меня есть (длинная) формула, которую вы можете использовать. Он не так хорошо отточен, как те, что указаны выше - и работает только для фамилии, а не для полного имени - но вы можете найти это полезным.

Так что если у вас есть строка заголовка , и хотите , чтобы сравнить A2с B2, поместите это в любой другой ячейке в этой строке (например, C2) и скопировать вниз до конца.

= IF (A2 = B2, "EXACT", IF (ЗАМЕНА (A2, "-", "") = ЗАМЕНА (B2, "-", ""), "Дефис", IF (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (ЗАМЕНА (A2, B2, "")), "Whole String", IF (MID (A2,1,1) = MID (B2,1,1), 1, 0) + ЕСЛИ (MID (A2,2,1) = MID (B2,2,1), 1,0) + ЕСЛИ (MID (A2,3,1) = MID (B2,3,1), 1, 0) + ЕСЛИ (MID (А2, LEN (А2), 1) = MID (В2, LEN (В2), 1), 1,0) + ЕСЛИ (MID (А2, LEN (А2) -1,1) = MID (В2, LEN (В2) -1,1), 1,0) + ЕСЛИ (MID (А2, LEN (А2) -2,1) = MID (В2, LEN (В2) -2,1), 1 , 0) & "°"), IF (LEN (B2)> LEN (ЗАМЕНА (B2, A2, "")), "Whole String", IF (MID (A2,1,1) = MID (B2,1) , 1), 1,0) + ЕСЛИ (MID (A2,2,1) = MID (B2,2,1), 1,0) + ЕСЛИ (MID (A2,3,1) = MID (B2,3 , 1), 1,0) + ЕСЛИ (MID (А2, LEN (А2), 1) = MID (В2, LEN (В2), 1), 1,0) + ЕСЛИ (MID (А2, LEN (А2) -1,1) = MID (В2, LEN (B2) -1,1), 1,0) + ЕСЛИ (MID (А2, LEN (А2) -2,1) = MID (В2, LEN (В2) - 2,1), 1,0) & "°"))))

Это вернет:

• ТОЧНО - если это точное совпадение
• Дефис - если это пара двуствольных имен, но у них есть дефис, а у другого пробел
• Целая строка - если вся одна фамилия является частью другой (например, если Смит стал французами-Смитом)

После этого он даст вам степень от 0 ° до 6 ° в зависимости от количества точек сравнения между ними. (то есть 6 ° сравнивает лучше).

Как я уже сказал, немного грубо и готово, но, надеюсь, приведет вас примерно к правильному балл-парку.

Искал что-то подобное. Я нашел код ниже. Я надеюсь, что это поможет следующему пользователю, который приходит к этому вопросу

Возвращает 91% для Абракадабры / Абракадабры, 75% для Голливуд-стрит / Улицы Святости, 62% для Флоренции / Франции и 0 для Диснейленда

Я бы сказал, что это достаточно близко к тому, что вы хотели :)

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

Вы можете использовать функцию подобия (pwrSIMILARITY), чтобы сравнить строки и получить процентное совпадение двух. Вы можете сделать это с учетом регистра или нет. Вам нужно будет решить, какой процент совпадений «достаточно близок» для ваших нужд.

Там есть справочная страница по адресу http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsdentifity/ .

Но это работает довольно хорошо для сравнения текста в столбце A с столбцом B.

Хотя мое решение не позволяет идентифицировать очень разные строки, оно полезно для частичного соответствия (совпадение подстроки), например, «это строка» и «строка» будет выглядеть как «соответствие»:

просто добавьте «*» до и после строки для поиска в таблице.

Обычная формула:

• ВПР (A1, B1: B10,1,0)
• cerca.vert (А1; В1: В10; 1; 0)

становится

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

«&» - это «короткая версия» для concatenate ()

Этот код сканирует столбцы a и b, если обнаруживает сходство в обоих столбцах, которые показаны желтым цветом. Вы можете использовать цветной фильтр, чтобы получить окончательное значение. Я не добавил эту часть в код.

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