Levenshtein Entfernung in VBA

Question

Ich habe Excel-Blatt mit Daten, die ich Levenshtein Entfernung zwischen ihnen erhalten möchte. Ich habe bereits versucht, als Text zu exportieren, aus dem Skript (php) einzulesen, Levenshtein auszuführen (Levenshtein Distance zu berechnen), es wieder in Excel zu speichern.

Aber ich bin auf der Suche nach einer Möglichkeit, eine Levenshtein Distance in VBA programmatisch zu berechnen. Wie würde ich das machen?

Answer 1

Übersetzt aus Wikipedia:

Option Explicit 
Public Function Levenshtein(s1 As String, s2 As String) 

Dim i As Integer 
Dim j As Integer 
Dim l1 As Integer 
Dim l2 As Integer 
Dim d() As Integer 
Dim min1 As Integer 
Dim min2 As Integer 

l1 = Len(s1) 
l2 = Len(s2) 
ReDim d(l1, l2) 
For i = 0 To l1 
    d(i, 0) = i 
Next 
For j = 0 To l2 
    d(0, j) = j 
Next 
For i = 1 To l1 
    For j = 1 To l2 
     If Mid(s1, i, 1) = Mid(s2, j, 1) Then 
      d(i, j) = d(i - 1, j - 1) 
     Else 
      min1 = d(i - 1, j) + 1 
      min2 = d(i, j - 1) + 1 
      If min2 < min1 Then 
       min1 = min2 
      End If 
      min2 = d(i - 1, j - 1) + 1 
      If min2 < min1 Then 
       min1 = min2 
      End If 
      d(i, j) = min1 
     End If 
    Next 
Next 
Levenshtein = d(l1, l2) 
End Function 

Levenshtein ("Samstag", "Sonntag")

Answer 2

Danke für den schönen Code Beitrag smirkingman. Hier ist eine optimierte Version.

1) Verwenden Sie Asc (Mid $ (s1, i, 1) statt. Numerical Vergleich ist in der Regel schneller als Text.

2) Verwenden Sie Mid $ istead von Mid seit der später ist die Variante ver. und das Hinzufügen von $ ist String ver.

3) Anwendungsfunktion für min. (nur persönliche Vorlieben)

4) Verwenden Sie Long statt Integer, da es genau das ist, was Excel verwendet.

Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long 

Dim i As Long, j As Long 
Dim string1_length As Long 
Dim string2_length As Long 
Dim distance() As Long 

string1_length = Len(string1) 
string2_length = Len(string2) 
ReDim distance(string1_length, string2_length) 

For i = 0 To string1_length 
    distance(i, 0) = i 
Next 

For j = 0 To string2_length 
    distance(0, j) = j 
Next 

For i = 1 To string1_length 
    For j = 1 To string2_length 
     If Asc(Mid$(string1, i, 1)) = Asc(Mid$(string2, j, 1)) Then 
      distance(i, j) = distance(i - 1, j - 1) 
     Else 
      distance(i, j) = Application.WorksheetFunction.Min _ 
      (distance(i - 1, j) + 1, _ 
      distance(i, j - 1) + 1, _ 
      distance(i - 1, j - 1) + 1) 
     End If 
    Next 
Next 

Levenshtein = distance(string1_length, string2_length) 

End Function 

UPDATE:

Für diejenigen, die es wollen: Ich denke, es ist sicher zu sagen, dass die meisten Menschen Levenshtein Abstand verwenden Fuzzy-Match Prozentsätze zu berechnen. Hier ist eine Möglichkeit, dies zu tun, und ich habe eine Optimierung hinzugefügt, die Sie die min angeben können. passe% an, um zurückzukehren (Standard ist 70% +. Du gibst Prozentzahlen wie "50" oder "80" oder "0" ein, um die Formel unabhängig auszuführen).

Die Geschwindigkeitssteigerung kommt von der Tatsache, dass die Funktion prüft, ob es sogar möglich ist, dass es innerhalb des Prozentsatzes ist, den Sie geben, indem Sie die Länge der 2 Zeichenfolgen überprüfen. Bitte beachten Sie, dass es einige Bereiche gibt, in denen diese Funktion optimiert werden kann, aber ich habe sie aus Gründen der besseren Lesbarkeit beibehalten. Ich verkettet, um die Strecke in Folge für den Nachweis der Funktionalität, aber man kann mit ihm Geige :)

Function FuzzyMatch(ByVal string1 As String, _ 
        ByVal string2 As String, _ 
        Optional min_percentage As Long = 70) As String 

Dim i As Long, j As Long 
Dim string1_length As Long 
Dim string2_length As Long 
Dim distance() As Long, result As Long 

string1_length = Len(string1) 
string2_length = Len(string2) 

' Check if not too long 
If string1_length >= string2_length * (min_percentage/100) Then 
    ' Check if not too short 
    If string1_length <= string2_length * ((200 - min_percentage)/100) Then 

     ReDim distance(string1_length, string2_length) 
     For i = 0 To string1_length: distance(i, 0) = i: Next 
     For j = 0 To string2_length: distance(0, j) = j: Next 

     For i = 1 To string1_length 
      For j = 1 To string2_length 
       If Asc(Mid$(string1, i, 1)) = Asc(Mid$(string2, j, 1)) Then 
        distance(i, j) = distance(i - 1, j - 1) 
       Else 
        distance(i, j) = Application.WorksheetFunction.Min _ 
        (distance(i - 1, j) + 1, _ 
        distance(i, j - 1) + 1, _ 
        distance(i - 1, j - 1) + 1) 
       End If 
      Next 
     Next 
     result = distance(string1_length, string2_length) 'The distance 
    End If 
End If 

If result <> 0 Then 
    FuzzyMatch = (CLng((100 - ((result/string1_length) * 100)))) & _ 
       "% (" & result & ")" 'Convert to percentage 
Else 
    FuzzyMatch = "Not a match" 
End If 

End Function 

Answer 3

Verwenden Sie ein Byte-Array für 17x Geschwindigkeitsverstärkung

Option Explicit 

    Public Declare Function GetTickCount Lib "kernel32"() As Long 

    Sub test() 
    Dim s1 As String, s2 As String, lTime As Long, i As Long 
    s1 = Space(100) 
    s2 = String(100, "a") 
    lTime = GetTickCount 
    For i = 1 To 100 
    LevenshteinStrings s1, s2 ' the original fn from Wikibooks and Stackoverflow 
    Next 
    Debug.Print GetTickCount - lTime; " ms" ' 3900 ms for all diff 

    lTime = GetTickCount 
    For i = 1 To 100 
    Levenshtein s1, s2 
    Next 
    Debug.Print GetTickCount - lTime; " ms" ' 234 ms 

    End Sub 

    'Option Base 0 assumed 

    'POB: fn with byte array is 17 times faster 
    Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long 

    Dim i As Long, j As Long, bs1() As Byte, bs2() As Byte 
    Dim string1_length As Long 
    Dim string2_length As Long 
    Dim distance() As Long 
    Dim min1 As Long, min2 As Long, min3 As Long 

    string1_length = Len(string1) 
    string2_length = Len(string2) 
    ReDim distance(string1_length, string2_length) 
    bs1 = string1 
    bs2 = string2 

    For i = 0 To string1_length 
     distance(i, 0) = i 
    Next 

    For j = 0 To string2_length 
     distance(0, j) = j 
    Next 

    For i = 1 To string1_length 
     For j = 1 To string2_length 
      'slow way: If Mid$(string1, i, 1) = Mid$(string2, j, 1) Then 
      If bs1((i - 1) * 2) = bs2((j - 1) * 2) Then ' *2 because Unicode every 2nd byte is 0 
       distance(i, j) = distance(i - 1, j - 1) 
      Else 
       'distance(i, j) = Application.WorksheetFunction.Min _ 
       (distance(i - 1, j) + 1, _ 
       distance(i, j - 1) + 1, _ 
       distance(i - 1, j - 1) + 1) 
       ' spell it out, 50 times faster than worksheetfunction.min 
       min1 = distance(i - 1, j) + 1 
       min2 = distance(i, j - 1) + 1 
       min3 = distance(i - 1, j - 1) + 1 
       If min1 <= min2 And min1 <= min3 Then 
        distance(i, j) = min1 
       ElseIf min2 <= min1 And min2 <= min3 Then 
        distance(i, j) = min2 
       Else 
        distance(i, j) = min3 
       End If 

      End If 
     Next 
    Next 

    Levenshtein = distance(string1_length, string2_length) 

    End Function 

Answer 4

Ich denke, es kam noch schneller ... Haben Sie nicht viel tun, außer vorherigen Code für die Geschwindigkeit und die Ergebnisse als% zu

' Levenshtein3 tweaked for UTLIMATE speed and CORRECT results 
' Solution based on Longs 
' Intermediate arrays holding Asc()make difference 
' even Fixed length Arrays have impact on speed (small indeed) 
' Levenshtein version 3 will return correct percentage 
' 
Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long 

Dim i As Long, j As Long, string1_length As Long, string2_length As Long 
Dim distance(0 To 60, 0 To 50) As Long, smStr1(1 To 60) As Long, smStr2(1 To 50) As Long 
Dim min1 As Long, min2 As Long, min3 As Long, minmin As Long, MaxL As Long 

string1_length = Len(string1): string2_length = Len(string2) 

distance(0, 0) = 0 
For i = 1 To string1_length: distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): Next 
For j = 1 To string2_length: distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): Next 
For i = 1 To string1_length 
    For j = 1 To string2_length 
     If smStr1(i) = smStr2(j) Then 
      distance(i, j) = distance(i - 1, j - 1) 
     Else 
      min1 = distance(i - 1, j) + 1 
      min2 = distance(i, j - 1) + 1 
      min3 = distance(i - 1, j - 1) + 1 
      If min2 < min1 Then 
       If min2 < min3 Then minmin = min2 Else minmin = min3 
      Else 
       If min1 < min3 Then minmin = min1 Else minmin = min3 
      End If 
      distance(i, j) = minmin 
     End If 
    Next 
Next 

' Levenshtein3 will properly return a percent match (100%=exact) based on similarities and Lengths etc... 
MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length 
Levenshtein3 = 100 - CLng((distance(string1_length, string2_length) * 100)/MaxL) 

End Function