Определить аббревиатуры при запуске кода вычисления vb, подсчитывая сходство

Question

Я использую следующий код vb в excel для вычисления степени сходства между столбцом A и столбцом B. Он отлично работает.

Следующим шагом для меня является определение акронимов, поэтому рассчитанная степень сходства не влияет. IE: Если у меня в столбце A, «ABC LLC» и в колонке B «Общество с ограниченной ответственностью ABC», текущий код vb вернет, что два столбца не очень похожи. Тем не менее, я хочу, чтобы они вернулись на 100%, указав, что «ООО» и «Общество с ограниченной ответственностью» - это одно и то же. Что я могу сделать и где я могу поместить его в код, чтобы выполнить это? Благодаря!

Отказ от ответственности - да, я знаю, что есть надстройки для этого. Однако мой набор данных слишком велик, чтобы использовать их.

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

без особого участия в ваше решение, что это ваша собственная ответственность, я могу предложить какой-нибудь способ, чтобы включить эти Сокращения. Однако. Просьба помнить, что этот метод не гарантирует 100% успеха, но вы уже в нечетком мире.

Предположим, что мы имеем Dictionary где:

• Ключи представляют собой длинные фразы
• Значения аббревиатуры

Прежде чем сравнивать две строки, мы минимизировать оба из них , заменив каждую длинную фразу на ее аббревиатуру. Затем мы можем сравнить их с остальной частью вашего метода Similarity (или любым другим способом).

' 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

Возможно, было бы легче проверить, нет ли строк Like. Например

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

это правда, как * спичек любые 0 или более символов.

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