So sánh các chuỗi văn bản tương tự trong Excel

Tôi hiện đang cố gắng điều hòa các trường Tên Tên từ hai nguồn dữ liệu riêng biệt. Tôi có một số tên không khớp chính xác nhưng đủ gần để được coi là khớp (ví dụ bên dưới). Bạn có ý tưởng nào về cách tôi có thể cải thiện số lượng trận đấu tự động không? Tôi đã loại bỏ tên viết tắt giữa khỏi tiêu chí phù hợp.

Công thức trận đấu hiện tại:

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

Bạn có thể cân nhắc sử dụng Addin tra cứu mờ của Microsoft .

Từ trang web của MS:

Tổng quat

Bổ trợ tra cứu mờ cho Excel được phát triển bởi Microsoft Research và thực hiện kết hợp mờ dữ liệu văn bản trong Microsoft Excel. Nó có thể được sử dụng để xác định các hàng trùng lặp mờ trong một bảng hoặc để nối mờ các hàng tương tự giữa hai bảng khác nhau. Sự phù hợp mạnh mẽ với nhiều lỗi khác nhau bao gồm lỗi chính tả, viết tắt, từ đồng nghĩa và dữ liệu được thêm / thiếu. Chẳng hạn, nó có thể phát hiện ra rằng các hàng Mr. Andrew Hill Cảnh, Hill Hill, Andrew R. Giao và cả Andy Hill Hill đều đề cập đến cùng một thực thể cơ bản, trả lại điểm tương đồng cùng với mỗi trận đấu. Mặc dù cấu hình mặc định hoạt động tốt cho nhiều loại dữ liệu văn bản, chẳng hạn như tên sản phẩm hoặc địa chỉ khách hàng, sự phù hợp cũng có thể được tùy chỉnh cho các tên miền hoặc ngôn ngữ cụ thể.

Tôi sẽ xem xét việc sử dụng danh sách này (chỉ phần tiếng Anh) để giúp loại bỏ các rút ngắn phổ biến.

Ngoài ra, bạn có thể muốn xem xét sử dụng một hàm sẽ cho bạn biết, về mặt chính xác, mức độ "đóng" của hai chuỗi. Các mã sau đây đến từ đây và nhờ 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

Điều này sẽ làm là cho bạn biết có bao nhiêu lần chèn và xóa mà một người phải làm với một chuỗi để đến chuỗi khác. Tôi sẽ cố gắng giữ con số này ở mức thấp (và tên chính xác phải chính xác).

Tôi có một công thức (dài) mà bạn có thể sử dụng. Nó không được mài giũa như những người ở trên - và chỉ hoạt động cho họ, chứ không phải là tên đầy đủ - nhưng bạn có thể thấy nó hữu ích.

Vì vậy, nếu bạn có một dòng tiêu đề và muốn so sánh A2với B2, đặt này trong bất kỳ tế bào khác trên hàng đó (ví dụ C2) và sao chép xuống đến cùng.

= IF (A2 = B2, "CHÍNH XÁC", IF (SUBSTITUTE (A2, "-", "") = SUBSTITUTE (B2, "-", ""), "Dấu gạch ngang", IF (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUBSTITUTE (A2, B2, "")), "Toàn chuỗi", 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, "")), "Toàn chuỗi", 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) & "°"))))

Điều này sẽ trở lại:

• Chính xác - nếu đó là một trận đấu chính xác
• Dấu gạch nối - nếu đó là một cặp tên hai nòng nhưng trên có dấu gạch nối và dấu cách khác
• Toàn bộ chuỗi - nếu tất cả họ này là một phần của chuỗi khác (ví dụ: nếu Smith đã trở thành Pháp-Smith)

Sau đó, nó sẽ cung cấp cho bạn một mức độ từ 0 ° đến 6 ° tùy thuộc vào số điểm so sánh giữa hai. (tức là 6 ° so sánh tốt hơn).

Như tôi nói hơi thô bạo và sẵn sàng, nhưng hy vọng sẽ đưa bạn đến gần công viên bóng.

Đã tìm kiếm một cái gì đó tương tự. Tôi tìm thấy mã dưới đây. Tôi hy vọng điều này sẽ giúp người dùng tiếp theo đến với câu hỏi này

Trả lại 91% cho Abracadabra / Abrakadabra, 75% cho Hollywood Street / Hollyhood Str, 62% cho Florence / France và 0 cho Disneyland

Tôi muốn nói rằng nó đủ gần với những gì bạn muốn :)

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

Bạn có thể sử dụng hàm tương tự (pwrSIMILARITY) để so sánh các chuỗi và có được tỷ lệ phần trăm khớp của hai chuỗi. Bạn có thể làm cho nó phân biệt chữ hoa chữ thường hoặc không. Bạn sẽ cần phải quyết định bao nhiêu phần trăm của trận đấu là "đủ gần" cho nhu cầu của bạn.

Có một trang tham khảo tại http://officepowerups.com/help-support/excel-feft-reference/excel-text-analyzer/pwrsimilarity/ .

Nhưng nó hoạt động khá tốt để so sánh văn bản trong cột A với cột B.

Mặc dù giải pháp của tôi không cho phép xác định các chuỗi rất khác nhau, nhưng nó rất hữu ích cho đối sánh một phần (khớp chuỗi con), ví dụ: "đây là một chuỗi" và "một chuỗi" sẽ dẫn đến "khớp":

chỉ cần thêm "*" trước và sau chuỗi cần tìm vào bảng.

Công thức thông thường:

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

trở thành

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

"&" là "phiên bản ngắn" cho concatenate ()

Mã này quét cột a và cột b, nếu nó tìm thấy bất kỳ sự tương đồng trong cả hai cột, nó sẽ hiển thị màu vàng. Bạn có thể sử dụng bộ lọc màu để có được giá trị cuối cùng. Tôi chưa thêm phần đó vào mã.

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