Порівняння подібних текстових рядків в 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:

Огляд

Надбудова Fuzzy Lookup для Excel була розроблена компанією Microsoft Research і виконує нечітке узгодження текстових даних у Microsoft Excel. Його можна використовувати для ідентифікації нечітких повторюваних рядків у межах однієї таблиці або для нечіткого з'єднання подібних рядків між двома різними таблицями. Відповідність є надійною для найрізноманітніших помилок, включаючи орфографічні помилки, скорочення, синоніми та додані / відсутні дані. Наприклад, це може виявити, що рядки "Mr. Ендрю Хілл "," Хілл, Ендрю Р. " і "Енді Хілл" усі відносяться до одного і того ж основного об'єкта, повертаючи показник подібності разом з кожним матчем. Хоча конфігурація за замовчуванням добре працює для найрізноманітніших текстових даних, таких як назви продуктів або адреси клієнтів, відповідність також може бути налаштована для конкретних доменів або мов.

Я хотів би скористатися цим списком (лише англійський розділ), щоб допомогти усунути загальні скорочення.

Крім того, ви, можливо, захочете скористатися функцією, яка точно скаже вам про те, як "закрити" дві рядки. Наступний код прийшов звідси і завдяки 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

Що це зробить, це сказати вам, скільки вставок та видалень потрібно зробити одному рядку, щоб дістатися до іншого. Я б спробував утримати це число низьким (а прізвища мають бути точними).

У мене є (довга) формула, яку ви можете використовувати. Це не так добре відточено, як описано вище - і працює лише на прізвище, а не на повне ім’я - але ви можете вважати його корисним.

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

= ЯКЩО (A2 = B2, "EXACT", IF (SUBSTITUTE (A2, "-", "") = SUBSTITUTE (B2, "-", ""), "Дефіс", IF (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUBSTITUTE (A2, B2, "")), "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) + ІФ (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) і "°"), АБО (LEN (B2)> LEN (ЗАМОВЛЕННЯ (B2, A2, "")), "Ціла струна", АКО (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) і "°"))))

Це поверне:

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

Після цього він отримає ступінь від 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/pwrs similarity/ .

Але він працює досить добре для порівняння тексту у колонці А проти стовпця B.

Хоча моє рішення не дозволяє ідентифікувати дуже різні рядки, воно корисне для часткового збігу (збігу підрядків), наприклад "це рядок" і "рядок" призведе до "збігу":

просто додайте "*" до і після рядка, щоб шукати в таблиці.

Звичайна формула:

• vlookup (A1, B1: B10,1,0)
• cerca.vert (A1; B1: B10; 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