특정 문자열과 가장 가까운 단어를 찾으십니까?

Question

특정 사용자에게 할당 된 전자 메일 아이디를 찾아야한다는 점에서 사용자 조정 보고서를 작성합니다. 전

고객 보고서 사용자 이름

그래서이

Sathish Kothandam 
Sathya Arjun 

과 같이 될 것입니다이

Sathish K 
Sathya A 

처럼 그러나 우리의 통합 보고서 실제 사용자 이름으로 보일 수 있습니다 매크로를 만들었습니다

Sub test 
Dim t as string 
t= “Sathish K” 
msgbox(getemailId(t)) 
End sub 

    Dim rng As Range 

Function getemailId(Byval findString As String) 
    With ActiveWorkbook.Sheets("CONSOLIDATED").Range("B:B") 
     Set rng = .find(What:=findString, LookIn:=xlValues) 
     If Not rng Is Nothing Then 
‘ B – Column contains username C – Email id of the user 
      getemailId = rng.offset(0,1).value 
     Else 
      find1 = 0 
     End If 
    End With 
End Function 

내 매크로 완벽하게 시나리오 위에서 작동하지만 언젠가 나는 아래

Satish Kothandam 
Sathiya Arjun 

같은 사용자 이름을 수신 할 수 있지만 0 반환이 시간. 어쨌든 내 목표를 달성 할 수있는 방법이 있습니까? 희망은 잘 설명 되었습니까?

Answer 1

아래 샘플 코드를 참조하십시오.

Sub test() 

Dim str1 As String, str2 As String 
Dim str1c As String, str2c As String 

str1 = "Sathish" 
str2 = "Satish" 

str1c = SOUNDEX(str1) 
str2c = SOUNDEX(str2) 

MsgBox str1c = str2c 

End Sub 

는

Function SOUNDEX(Surname As String) As String 
' Developed by Richard J. Yanco 
' This function follows the Soundex rules given at 
' http://home.utah-inter.net/kinsearch/Soundex.html 

    Dim Result As String, c As String * 1 
    Dim Location As Integer 

    Surname = UCase(Surname) 

' First character must be a letter 
    If Asc(Left(Surname, 1)) < 65 Or Asc(Left(Surname, 1)) > 90 Then 
     SOUNDEX = "" 
     Exit Function 
    Else 
'  St. is converted to Saint 
     If Left(Surname, 3) = "ST." Then 
      Surname = "SAINT" & Mid(Surname, 4) 
     End If 

'  Convert to Soundex: letters to their appropriate digit, 
'      A,E,I,O,U,Y ("slash letters") to slashes 
'      H,W, and everything else to zero-length string 

     Result = Left(Surname, 1) 
     For Location = 2 To Len(Surname) 
      Result = Result & Category(Mid(Surname, Location, 1)) 
     Next Location 

'  Remove double letters 
     Location = 2 
     Do While Location < Len(Result) 
      If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then 
       Result = Left(Result, Location) & Mid(Result, Location + 2) 
      Else 
       Location = Location + 1 
      End If 
     Loop 

'  If category of 1st letter equals 2nd character, remove 2nd character 
     If Category(Left(Result, 1)) = Mid(Result, 2, 1) Then 
      Result = Left(Result, 1) & Mid(Result, 3) 
     End If 

'  Remove slashes 
     For Location = 2 To Len(Result) 
      If Mid(Result, Location, 1) = "/" Then 
       Result = Left(Result, Location - 1) & Mid(Result, Location + 1) 
      End If 
     Next 

'  Trim or pad with zeroes as necessary 
     Select Case Len(Result) 
      Case 4 
       SOUNDEX = Result 
      Case Is < 4 
       SOUNDEX = Result & String(4 - Len(Result), "0") 
      Case Is > 4 
       SOUNDEX = Left(Result, 4) 
     End Select 
    End If 
End Function 

Private Function Category(c) As String 
' Returns a Soundex code for a letter 
    Select Case True 
     Case c Like "[AEIOUY]" 
      Category = "/" 
     Case c Like "[BPFV]" 
      Category = "1" 
     Case c Like "[CSKGJQXZ]" 
      Category = "2" 
     Case c Like "[DT]" 
      Category = "3" 
     Case c = "L" 
      Category = "4" 
     Case c Like "[MN]" 
      Category = "5" 
     Case c = "R" 
      Category = "6" 
     Case Else 'This includes H and W, spaces, punctuation, etc. 
      Category = "" 
    End Select 
End Function 

Answer 2

당신은 levenshtein의 algorythm을 사용할 수 있습니다. 두 개의 문자열 사이의 거리를 계산합니다.

소스 위키 미디어

Function levenshtein(a As String, b As String) As Integer 

    Dim i As Integer 
    Dim j As Integer 
    Dim cost As Integer 
    Dim d() As Integer 
    Dim min1 As Integer 
    Dim min2 As Integer 
    Dim min3 As Integer 

    If Len(a) = 0 Then 
     levenshtein = Len(b) 
     Exit Function 
    End If 

    If Len(b) = 0 Then 
     levenshtein = Len(a) 
     Exit Function 
    End If 

    ReDim d(Len(a), Len(b)) 

    For i = 0 To Len(a) 
     d(i, 0) = i 
    Next 

    For j = 0 To Len(b) 
     d(0, j) = j 
    Next 

    For i = 1 To Len(a) 
     For j = 1 To Len(b) 
      If Mid(a, i, 1) = Mid(b, j, 1) Then 
       cost = 0 
      Else 
       cost = 1 
      End If 

      ' Since Min() function is not a part of VBA, we'll "emulate" it below 
      min1 = (d(i - 1, j) + 1) 
      min2 = (d(i, j - 1) + 1) 
      min3 = (d(i - 1, j - 1) + cost) 

'   If min1 <= min2 And min1 <= min3 Then 
'    d(i, j) = min1 
'   ElseIf min2 <= min1 And min2 <= min3 Then 
'    d(i, j) = min2 
'   Else 
'    d(i, j) = min3 
'   End If 
'   In Excel we can use Min() function that is included 
'   as a method of WorksheetFunction object 
      d(i, j) = Application.WorksheetFunction.Min(min1, min2, min3) 
     Next 
    Next 
    levenshtein = d(Len(a), Len(b)) 

End Function