VBA создать справочный словарь для акронимов

Question

Я реализую действительно полезный код, который вычисляет степень сходства между двумя столбцами. Пример. В первом столбце содержатся «ABC Company», а в столбце 2 «ABCD Company». Затем код VBA вернет, что столбец 1 и столбец 2 похожи на 99%. Это отлично работает!

Мой вопрос/вопрос: теперь я хотел бы добавить код, который распознает акронимы или рассматривает два слова как одно и то же. Пример: если в столбце 1 «ABC LLC» и в столбце 2 содержится «Общество с ограниченной ответственностью ABC», я хотел бы, чтобы код признал, что «ООО» и «Общество с ограниченной ответственностью» на самом деле то же самое. Могу ли я определить это в словаре или установить эти две вещи равными друг другу как-то ?? Благодаря! Код, который я должен был добавить к перечислен ниже

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`enter code here`) 

    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

Это, наверное, проще всего сделать:

If str = "LLC" then 
    str.replace("LLC","Limited Liability Company") 
end if 

Положите его в Еогеасп, с двумя списками и искать что-то изменить. Что-то вроде этого:

Option Explicit 

Public Sub CheckMe() 

    Dim ListA  As Collection 
    Dim ListB  As Collection 
    Dim str   As String 
    Dim strResult As String 

    Dim varStr  As Variant 
    Dim var   As Variant 
    Dim varAdd  As Variant 

    Dim counter  As Variant 

    str = "LiLaCa is a AnAtBaa company" 
    strResult = "" 

    Set ListA = New Collection 
    Set ListB = New Collection 

    ListA.Add ("LLC") 
    ListA.Add ("AAB") 
    ListA.Add ("BBA") 

    ListB.Add ("LiLaCa") 
    ListB.Add ("AnAtBaa") 
    ListB.Add ("BuBuAaaaaa") 

    varStr = Split(str) 

    For Each var In varStr 
     varAdd = var 
     For counter = 1 To ListB.Count 
      If var = ListB(counter) Then varAdd = Replace(var, ListB(counter), ListA(counter)) 
     Next counter 
     strResult = strResult & varAdd & " " 
    Next var 

    Debug.Print strResult 

End Sub