การเปรียบเทียบสตริงข้อความที่คล้ายกันใน 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 เลือนค้นหา Addin

จากเว็บไซต์ MS:

ภาพรวม

Add-In Lookup ของ Fuzzy สำหรับ Excel ได้รับการพัฒนาโดย Microsoft Research และทำการจับคู่แบบเลือนของข้อมูลที่เป็นข้อความใน Microsoft Excel มันสามารถใช้ในการระบุแถวที่ซ้ำกันเลือนภายในตารางเดียวหรือเพื่อเข้าร่วมแถวที่คล้ายกันเลือนระหว่างสองตารางที่แตกต่างกัน การจับคู่มีความทนทานต่อข้อผิดพลาดที่หลากหลายรวมถึงข้อผิดพลาดการสะกดคำย่อคำพ้องความหมายและข้อมูลที่เพิ่ม / หายไป ตัวอย่างเช่นมันอาจตรวจพบว่าแถว“ นาย Andrew Hill”,“ Hill, Andrew R. ” และ“ Andy Hill” ทั้งหมดอ้างถึงเอนทิตีต้นแบบเดียวกันส่งคืนคะแนนความคล้ายคลึงพร้อมกับการแข่งขันแต่ละครั้ง ในขณะที่การกำหนดค่าเริ่มต้นทำงานได้ดีสำหรับข้อมูลที่หลากหลายเช่นชื่อผลิตภัณฑ์หรือที่อยู่ลูกค้าการจับคู่อาจถูกปรับแต่งสำหรับโดเมนหรือภาษาเฉพาะ

ฉันจะพิจารณาการใช้รายการนี้ (ส่วนภาษาอังกฤษเท่านั้น) เพื่อช่วยกำจัดการย่อทั่วไป

นอกจากนี้คุณอาจต้องการพิจารณาการใช้ฟังก์ชั่นที่จะบอกคุณในแง่ที่แน่นอนว่าสองสาย "ปิด" เป็นอย่างไร รหัสต่อไปนี้มาจากที่นี่และขอขอบคุณที่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) และคัดลอกลงไปยังจุดสิ้นสุด

= IF (A2 = B2, "EXACT", IF (SUBSTITUTE (A2, "-", "") = SUBSTITUTE (B2, "-", "", "Hyphen", IF (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUBSTITUTE (A2, B2, "")), "สตริงทั้งหมด", 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, "")), "สตริงทั้งหมด", 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) และ "องศา"))))

สิ่งนี้จะส่งคืน:

• ที่แน่นอน - หากเป็นการจับคู่ที่ตรงกัน
• ยัติภังค์ - ถ้ามันเป็นชื่อคู่ที่มีลำกล้องสองอัน แต่จะมียัติภังค์และอีกอันหนึ่งเว้นวรรค
• สตริงทั้งหมด - หากนามสกุลทั้งหมดเป็นส่วนหนึ่งของอีกส่วน (เช่นหาก Smith กลายเป็น French-Smith)

หลังจากนั้นมันจะให้ระดับจาก 0 °ถึง 6 °ขึ้นอยู่กับจำนวนจุดเปรียบเทียบระหว่างสอง (เช่น 6 °เปรียบเทียบดีกว่า)

อย่างที่ฉันบอกว่าค่อนข้างหยาบและพร้อม แต่หวังว่าจะทำให้คุณอยู่ในสวนบอลล์ที่ใช่

กำลังค้นหาสิ่งที่คล้ายกัน ฉันพบรหัสด้านล่าง ฉันหวังว่านี่จะช่วยให้ผู้ใช้รายต่อไปที่มาถึงคำถามนี้

ส่งคืน 91% สำหรับ Abracadabra / Abrakadabra, 75% สำหรับ Hollywood Street / Hollyhood Str, 62% สำหรับ Florence / France และ 0 สำหรับ Disneyland

ฉันว่ามันใกล้พอกับสิ่งที่คุณต้องการ :)

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/pwrsimilarity/

แต่มันใช้งานได้ดีในการเปรียบเทียบข้อความในคอลัมน์ A กับคอลัมน์ 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)

"&" เป็น "เวอร์ชั่นย่อ" สำหรับการต่อข้อมูล ()

รหัสนี้จะสแกนคอลัมน์ 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