Levenshtein Distance in VBA

Ho un foglio excel con i dati che voglio ottenere Levenshtein Distance tra di loro. Ho già provato ad esportare come testo, leggere dallo script (php), eseguire Levenshtein (calcola Levenshtein Distance), salvarlo per eccellere di nuovo.

Ma sto cercando un modo per calcolare in modo programmatico una distanza Levenshtein in VBA. Come potrei fare per farlo?

Tradotto da 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 ( "sabato", "Domenica")

3

Grazie a Smirkingman per il bel post in codice. Ecco una versione ottimizzata.

1) Utilizzare invece Asc (Mid $ (s1, i, 1). La comparazione numerica è generalmente più veloce del testo.

2) Utilizzare Mid $ istead of Mid poiché la successiva è la variante ver. e aggiungendo $ è la stringa ver.

3) Utilizzare la funzione di applicazione per min. (solo preferenza personale)

4) Utilizzare Long invece di interi poiché è quello che usa in modo eccellente.

 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 

AGGIORNAMENTO :

Per coloro che lo vogliono: penso che sia sicuro dire che la maggior parte delle persone usa la distanza di Levenshtein per calcolare le percentuali di partite fuzzy. Ecco un modo per farlo e ho aggiunto un’ottimizzazione che è ansible specificare il valore min. match% da restituire (il valore predefinito è 70% +. Si inseriscono percentag come “50” o “80” o “0” per eseguire la formula indipendentemente).

L’aumento di velocità deriva dal fatto che la funzione controllerà se è anche ansible che sia all’interno della percentuale che gli viene data controllando la lunghezza delle 2 stringhe. Si prega di notare che ci sono alcune aree in cui questa funzione può essere ottimizzata, ma l’ho mantenuta per motivi di leggibilità. Ho concatenato la distanza nel risultato per la dimostrazione di funzionalità, ma puoi giocarci 🙂

 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 

Utilizzare un array di byte per guadagno di velocità 17x

  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 

Penso che sia diventato ancora più veloce … Non ho fatto altro che migliorare il codice precedente per velocità e risultati in%

 ' 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