Membandingkan String Teks Serupa di Excel

Saat ini saya mencoba untuk merekonsiliasi bidang "Nama" dari dua sumber data terpisah. Saya memiliki sejumlah nama yang tidak sama persis tetapi cukup dekat untuk dianggap cocok (contoh di bawah). Apakah Anda punya ide tentang bagaimana saya dapat meningkatkan jumlah pencocokan otomatis? Saya sudah menghilangkan inisial tengah dari kriteria pertandingan.

Formula Pertandingan Saat Ini:

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

Anda mungkin mempertimbangkan untuk menggunakan Microsoft Fuzzy Lookup Addin .

Dari situs MS:

Gambaran

Add-In Fuzzy Lookup untuk Excel dikembangkan oleh Microsoft Research dan melakukan pencocokan fuzzy data tekstual di Microsoft Excel. Ini dapat digunakan untuk mengidentifikasi baris duplikat fuzzy dalam satu tabel atau untuk menggabungkan fuzzy baris yang sama antara dua tabel yang berbeda. Pencocokan kuat untuk berbagai kesalahan termasuk kesalahan pengejaan, singkatan, sinonim, dan data yang ditambahkan / hilang. Misalnya, mungkin mendeteksi bahwa baris "Mr. Andrew Hill "," Hill, Andrew R. " dan "Andy Hill" semuanya merujuk ke entitas yang mendasari yang sama, mengembalikan skor kesamaan bersama dengan setiap pertandingan. Sementara konfigurasi default berfungsi dengan baik untuk berbagai data tekstual, seperti nama produk atau alamat pelanggan, pencocokan juga dapat disesuaikan untuk domain atau bahasa tertentu.

Saya akan melihat ke dalam menggunakan daftar ini (hanya bagian bahasa Inggris) untuk membantu menghilangkan kekurangan umum.

Selain itu, Anda mungkin ingin mempertimbangkan untuk menggunakan fungsi yang akan memberi tahu Anda, dalam istilah yang tepat, bagaimana "tutup" dua string. Kode berikut datang dari sini dan terima kasih kepada 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

Apa yang akan dilakukan adalah memberi tahu Anda berapa banyak penyisipan dan penghapusan yang harus dilakukan untuk satu string untuk mendapatkan yang lainnya. Saya akan mencoba untuk menjaga angka ini tetap rendah (dan nama belakang harus tepat).

Saya memiliki rumus (panjang) yang dapat Anda gunakan. Ini tidak diasah sebaik yang di atas - dan hanya bekerja untuk nama keluarga, bukan nama lengkap - tetapi Anda mungkin menemukan itu berguna.

Jadi, jika Anda memiliki baris tajuk dan ingin dibandingkan A2dengan B2, letakkan ini di sel lain di baris itu (mis., C2) Dan salin sampai akhir.

= IF (A2 = B2, "EXACT", IF (SUBSTITUTE (A2, "-", "") = SUBSTITUTE (B2, "-", ""), "Tanda Hubung", IF (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (SUBSTITUTE (A2, B2, ",))," String Utuh ", 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, ",))," 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) + 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) & "°")))))

Ini akan mengembalikan:

• EXACT - jika itu sama persis
• Tanda hubung - jika sepasang nama berlipat ganda tetapi memiliki tanda hubung dan spasi lainnya
• Seluruh string - jika semua satu nama adalah bagian dari yang lain (misalnya, jika Smith telah menjadi Smith-Prancis)

Setelah itu akan memberi Anda gelar dari 0 ° hingga 6 ° tergantung pada jumlah titik perbandingan antara keduanya. (yaitu, 6 ° lebih baik dibandingkan).

Seperti yang saya katakan agak kasar dan siap, tapi mudah-mudahan membuat Anda berada di ball-park yang tepat.

Sedang mencari sesuatu yang serupa. Saya menemukan kode di bawah ini. Saya harap ini membantu pengguna berikutnya yang datang ke pertanyaan ini

Mengembalikan 91% untuk Abracadabra / Abrakadabra, 75% untuk Hollywood Street / Hollyhood Str, 62% untuk Florence / Prancis dan 0 untuk Disneyland

Saya akan mengatakan itu cukup dekat dengan apa yang Anda inginkan :)

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

Anda dapat menggunakan fungsi kesamaan (pwrSIMILARITY) untuk membandingkan string dan mendapatkan persentase yang cocok dari keduanya. Anda bisa membuatnya case-sensitive atau tidak. Anda harus memutuskan persentase pertandingan yang "cukup dekat" untuk kebutuhan Anda.

Ada halaman referensi di http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsimilarity/ .

Tapi itu bekerja cukup baik untuk membandingkan teks di kolom A dengan kolom B.

Meskipun solusi saya tidak memungkinkan mengidentifikasi string yang sangat berbeda, ini berguna untuk kecocokan parsial (kecocokan substring), misalnya "ini adalah string" dan "string" akan menghasilkan "pencocokan":

cukup tambahkan "*" sebelum dan sesudah string untuk mencari ke dalam tabel.

Rumus biasa:

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

menjadi

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

"&" adalah "versi singkat" untuk concatenate ()

Kode ini memindai kolom a dan kolom b, jika menemukan kesamaan di kedua kolom yang ditunjukkan dengan warna kuning. Anda dapat menggunakan filter warna untuk mendapatkan nilai akhir. Saya belum menambahkan bagian itu ke dalam kode.

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