Excel'de Benzer Metin Dizelerini Karşılaştırma

Şu anda iki farklı veri kaynağından “Ad” alanları arasında mutabakat sağlamaya çalışıyorum. Tam eşleşme olmayan ancak eşleşecek kadar yakın olan birkaç adım var (aşağıdaki örnekler). Otomatik eşleşme sayısını nasıl artırabileceğime dair bir fikriniz var mı? Zaten orta harfleri maç kriterlerinden çıkarıyorum.

Güncel Maç Formülü:

=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 Bulanık Arama Eklentisini kullanmayı düşünebilirsiniz .

MS sitesinden:

genel bakış

Excel için Bulanık Arama Eklentisi Microsoft Research tarafından geliştirilmiştir ve Microsoft Excel'de metin verilerinin bulanık eşleştirmesini gerçekleştirir. Tek bir tablodaki bulanık yinelenen satırları tanımlamak veya iki farklı tablo arasındaki benzer satırları bulanık birleştirmek için kullanılabilir. Eşleme, yazım hataları, kısaltmalar, eşanlamlılar ve eklenen / eksik veriler dahil olmak üzere çok çeşitli hatalara karşı sağlamdır. Örneğin, satırların “Bay Andrew Hill ”,“ Hill, Andrew R. ” ve “Andy Hill” hepsi aynı temel varlığa atıfta bulunur ve her maçla birlikte benzerlik puanı verir. Varsayılan yapılandırma, ürün adları veya müşteri adresleri gibi çok çeşitli metin verileri için iyi çalışıyor olsa da, eşleme belirli alanlar veya diller için de özelleştirilebilir.

Ben kullanarak içine bakmak istiyorum bu ortak kısalmalara ayıklamak yardım listeyi (İngilizce bölüm yalnızca).

Ayrıca, tam olarak, iki dizenin ne kadar "kapatıldığını" belirten bir işlev kullanmayı düşünebilirsiniz. Aşağıdaki kod buradan ve smirkingman sayesinde geldi .

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

Bunun yapacağı şey, birinin diğerine ulaşmak için bir dizeye kaç ekleme ve silme yapması gerektiğini size söylemektir. Bu sayıyı düşük tutmaya çalıştım (ve soyadları tam olmalı).

Kullanabileceğiniz (uzun) bir formülüm var. Yukarıdaki kadar iyi honlanmış değildir - ve tam bir isimden ziyade sadece soyadı için çalışır - ancak yararlı bulabilirsiniz.

Eğer bir başlık satırı varsa ve karşılaştırmak istiyorsanız Yani A2birlikte B2, bu satırın (örneğin başka herhangi bir hücrede bu yerleştirmek C2) ve sonuna kadar aşağı kopyalayın.

= EĞER (A2 = B2, "EXACT", EĞER (YEDEK (A2, "-", "") = YERİNE (B2, "-", ""), "Kısa Çizgi", EĞER (LEN (A2)> LEN ( B2), IF (LEN (A2)> LEN (YEDEK (A2, B2, "")), "Tüm Dize", IF (MID (A2,1,1) = MID (B2,1,1), 1, 0) + EĞER (MID (A2,2,1) = ORTA (B2,2,1), 1,0) + EĞER (MID (A2,3,1) = ORTA (B2,3,1), 1, 0) + EĞER (MID (A2, UZ (A2), 1) = ARA (B2, UZ (B2), 1), 1,0) + EĞER (MID (A2, UZ (A2) -1,1) = ARA (B2, UZ (B2) -1,1), 1,0) + EĞER (MID (A2, UZ (A2) -2,1) = ARA (B2, UZ (B2) -2,1), 1 , 0) & "°"), IF (LEN (B2)> LEN (YEDEK (B2, A2, "")), "Tüm Dize", IF (MID (A2,1,1) = MID (B2,1 , 1), 1,0) + EĞER (MID (A2,2,1) = ORTA (B2,2,1), 1,0) + EĞER (MID (A2,3,1) = ARA (B2,3 , 1), 1,0) + EĞER (MID (A2, UZ (A2), 1) = ARA (B2, UZ (B2), 1), 1,0) + EĞER (MID (A2, UZ (A2) -1,1) ARA (B2, UZ (B2) -1,1), 1,0) = + EĞER (MID (A2, UZ (A2) -2,1) = ARA (B2, UZ (B2) - 2,1), 1,0) "°"))))

Bu geri dönecektir:

• EXACT - tam olarak eşleşiyorsa
• Kısa çizgi - bir çift çift namlulu isim, ancak üzerinde bir tire ve diğeri bir boşluk varsa
• Tüm dize - bir soyadın tümü diğerinin bir parçasıysa (örneğin, bir Smith Fransız-Smith olmuşsa)

Bundan sonra, ikisi arasındaki karşılaştırma noktalarının sayısına bağlı olarak 0 ° ila 6 ° arasında bir derece verecektir. (yani 6 ° daha iyi karşılaştırır).

Dediğim gibi biraz kaba ve hazır, ama umarım kabaca doğru top parkına alır.

Benzer bir şey arıyordum. Aşağıdaki kodu buldum. Umarım bu soruya gelen bir sonraki kullanıcıya yardımcı olur

Abracadabra / Abrakadabra için% 91, Hollywood Street / Hollyhood Str için% 75, Floransa / Fransa için% 62 ve Disneyland için 0 döndürür

İstediğine yeterince yakın olduğunu söyleyebilirim :)

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

Dizeleri karşılaştırmak ve ikisinin bir yüzde eşleşmesini elde etmek için benzerlik işlevini (pwrSIMILARITY) kullanabilirsiniz. Büyük / küçük harfe duyarlı hale getirebilirsiniz. Bir maçın yüzde kaçının ihtiyaçlarınız için "yeterince yakın" olduğuna karar vermeniz gerekir.

Http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrslikeity/ adresinde bir referans sayfası vardır .

Ancak A sütunundaki metni B sütunuyla karşılaştırmak için oldukça iyi çalışır.

Benim çözümüm çok farklı dizelerin tanımlanmasına izin vermese de, kısmi eşleme (alt dize eşleşmesi) için kullanışlıdır, örneğin "bu bir dizedir" ve "bir dize" "eşleştirme" ile sonuçlanır:

tabloya aramak için dizeden önce ve sonra "*" ekleyin.

Genel formül:

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

olur

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

"&", concatenate () için "kısa sürüm" dür

Bu kod tarama sütunu a ve sütun b, eğer her iki sütunda da benzerlik gösterirse sarı renkte gösterilir. Son değeri almak için renk filtresini kullanabilirsiniz. Bu parçayı koda eklemedim.

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