유사점 계산을위한 vb 코드 실행시 약어 정의

Question

Excel에서 다음과 같은 vb 코드를 사용하여 A 열과 B 열 간의 유사성을 계산합니다. 훌륭하게 실행됩니다.

나를위한 다음 단계는 계산 된 유사도가 영향을받지 않도록 두문자어를 정의하는 것입니다. IE : 컬럼 A, "ABC LLC"및 컬럼 B, "ABC 유한 책임 회사"에있는 경우, 현재 vb 코드는 두 컬럼이 유사하지 않음을 리턴합니다. 그러나 나는 "LLC"와 "Limited Liability Company"가 실제로 똑같은 것을 정의함으로써 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 개 이상의 문자로 True입니다.

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