Definieren Sie Akronyme, wenn Sie vb-Code ausführen und Ähnlichkeit berechnen

Question

Ich benutze den folgenden Vb-Code in Excel, um die Gradähnlichkeit zwischen Spalte A und Spalte B zu berechnen. Es läuft großartig.

Der nächste Schritt für mich ist Akronyme zu definieren, damit der berechnete Grad der Ähnlichkeit nicht beeinflusst wird. IE: Wenn ich in Spalte A, "ABC LLC" und in Spalte B, "ABC Gesellschaft mit beschränkter Haftung" habe, wird der aktuelle Vb-Code zurückgeben, dass die zwei Spalten nicht sehr ähnlich sind. Ich möchte jedoch, dass sie als 100% ähnlich zurückkehren, indem sie definieren, dass "LLC" und "Limited Liability Company" wirklich dasselbe sind. Was kann ich tun und wo kann ich es in den Code eingeben, um dies zu erreichen? Vielen Dank!

Haftungsausschluss - Ja, ich weiß, dass es Add-Ins dafür gibt. Mein Datensatz ist jedoch zu groß, um sie zu verwenden.

Public Function Similarity(ByVal String1 As String, _ 
          ByVal String2 As String, _ 
          Optional ByRef RetMatch As String, _ 
          Optional min_match = 1) As Single 

'Returns percentile of similarity between 2 strings (ignores case) 

'"RetMatch" returns the characters that match(in order) 
'"min_match" specifies minimum number af char's in a row to match 


Dim b1() As Byte, b2() As Byte 
Dim lngLen1 As Long, lngLen2 As Long 
Dim lngResult As Long 

    If UCase(String1) = UCase(String2) Then  '..Exactly the same 
    Similarity = 1 

    Else           '..one string is empty 
    lngLen1 = Len(String1) 
    lngLen2 = Len(String2) 
    If (lngLen1 = 0) Or (lngLen2 = 0) Then 
     Similarity = 0 

    Else          '..otherwise find similarity 
     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 each char of first string) 
    For lngCurr2 = start2 To end2  '(for each char of second string) 
     i = 0 
     Do Until b1(lngCurr1 + i) <> b2(lngCurr2 + i) 'as long as chars DO match.. 
     i = i + 1 
     If i > lngLongestMatch Then  '..if longer than previous best, store starts & length 
      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 'no matches at all, so no point checking for sub-matches! 

    lngLocalLongestMatch = lngLongestMatch     'call again for BEFORE + AFTER 
    RetMatch = "" 
           'Find longest match BEFORE the current position 
    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 

           'add local longest 
    RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch) 

           'Find longest match AFTER the current position 
    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 
          'Return result 
    Similarity_sub = lngLongestMatch 

End Function 

Answer 1

Ohne viel Engagement in die Lösung, das ist Ihre eigene Verantwortung, ich einen Weg vorschlagen, können diese Abkürzungen einzuarbeiten. Jedoch. Bitte beachten Sie, dass diese Methode nicht garantiert 100% Erfolg, aber Sie sind bereits in der Welt verschwommen.

Angenommen, wir ein Dictionary wo haben:

• Die Tasten sind die langen Sätze
• Die Werte sind die Abkürzungen

Vor dem Vergleich zweier Strings, wir beide von ihnen minimieren , indem jede auftretende lange Phrase durch ihre Abkürzung ersetzt wird. Dann können wir sie mit dem Rest Ihrer Methode vergleichen Similarity (oder mit einer anderen Methode).

' Fills an abbreviation dictionary 
Sub InitializeDict(ByRef abbrev As Scripting.Dictionary) 
    abbrev("limited liability company") = "LLC" 
    abbrev("United Kingdom") = "U.K." 
    '... Add all abbreviations into dict 

    ' Instead of harcoding, you can better load the key/value 
    ' pairs from a dedicated worksheet... 

End Sub 

' Minimizes s by putting abbreviations 
Sub Abbreviate(ByRef s As String) 
    Static abbrev As Scripting.Dictionary ' <-- static, inititlized only once 
    If abbrev Is Nothing Then 
     Set abbrev = CreateObject("Scripting.Dictionary") 
     abbrev.CompareMode = vbTextCompare 
     InitializeDict abbrev 
    End If 

    Dim phrase 
    For Each phrase In abbrev.Keys 
     s = Replace(s, phrase, abbrev(phrase), vbTextCompare) 
    Next 
End Sub 

' A small amendment to this function: abbreviate strings before comparing 
Public Function Similarity(ByVal String1 As String, _ 
         ByVal String2 As String, _ 
         Optional ByRef RetMatch As String, _ 
         Optional min_match = 1) As Single 

    Abbreviate String1 
    Abbreviate String2 
    ' ... Rest of the routine 
End Function 

Answer 2

Es könnte einfacher sein zu überprüfen, ob die Strings Like sich gegenseitig sind. Zum Beispiel

If "ABC limited liability company" Like "ABC L*L*C*" Then 

ist wahr als * Matches alle 0 oder mehr Zeichen.

Option Compare Text ' makes string comparisons case insensitive 

Function areLike(str1 As String, str2 As String) As Single 

    If str1 = str2 Then areLike = 1: Exit Function 

    Dim pattern As String, temp As String 

    If LenB(str1) < LenB(str2) Then 
     pattern = str1 
     temp = str2 
    Else 
     pattern = str2 
     temp = str1 
    End If 

    pattern = StrConv(pattern, vbUnicode)  ' "ABC LLC" to "A␀B␀C␀ ␀L␀L␀C␀" 
    pattern = Replace(pattern, vbNullChar, "*") ' "A*B*C* *L*L*C*" 
    pattern = Replace(pattern, " *", " ")  ' "A*B*C* L*L*C*" 

    If temp Like pattern Then areLike = 1: Exit Function 

    ' else areLike = some other similarity function 

End Function