Distanza di Levenshtein in VBA

Ho un foglio di excel con i dati che voglio ottenere Distanza di Levenshtein tra di loro. Ho già provato a esportare come testo, letto dallo script (php), esecuzione di Levenshtein (calcolare la Distanza di Levenshtein), si salva in excel.

Ma sto cercando un modo a livello di programmazione di calcolare una Distanza di Levenshtein in VBA. Come posso fare per farlo?

  • Perché è un tale incredibilmente utile post chiuso? Ho ascoltato ogni MODO podcast come è stato costruito, e mentre questo può essere la lettera della legge, non certo nello spirito del perché COSÌ era stato costruito. Triste.
  • D’accordo. La domanda priva di sforzo, ma molti lo fanno. E la stretta motivo è sbagliato, come può essere, a mio parere.
InformationsquelleAutor Yousf | 2010-11-22

 

4 Replies
  1. 56

    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

    ?Di Levenshtein(“sabato”,”domenica”)

    3

    • Questo codice funziona il drag and drop per l’Accesso di VBA troppo. 🙂
    • Breve nota per i futuri utenti, VBA Integer dichiara dovrebbe utilizzare meno memoria ed essere più veloce, ma ora sono automaticamente convertite in Long tipo dietro le quinte (fonte: MSDN, vedere questo troppo). Così, per il marginale incremento di prestazioni, dichiarando come Long salva sulla conversione interna del tempo (alcune altre risposte vedo che hanno fatto uso di questo). O, se le stringhe sono sotto 255 caratteri in lunghezza, dichiarare come Bytes come questo richiede una quantità di memoria inferiore rispetto Integer.
  2. 28

    Grazie a smirkingman per il bel codice postale. Qui è una versione ottimizzata.

    1) Utilizzare Asc(Mid$(s1, i, 1), invece. Numerico confronto è generalmente più veloce rispetto al testo.

    2) Utilizzare Mid$ istead della Metà, poiché il secondo è la variante ver. e l’aggiunta di $ stringa ver.

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

    4) Uso a Lungo invece di numeri Interi dal momento che è quello che excel in modo nativo usa.

    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 chi lo desidera: penso che sia sicuro dire che la maggior parte delle persone usano distanza di Levenshtein, per calcolare fuzzy match percentuali. Ecco un modo per farlo, e ho aggiunto un’ottimizzazione che si può specificare il min. match % di ritorno (di default è il 70% in+. Inserisci percentags come “50” e “80”, o “0” per eseguire la formula a prescindere).

    Il boost di velocità deriva dal fatto che la funzione di verificare se è ancora possibile che la percentuale si dà da controllare la lunghezza delle 2 stringhe. Si prega di notare che ci sono alcune aree in cui questa funzione può essere ottimizzato, ma ho conservato presso questo per migliorarne la leggibilità. Ho concatenato la distanza in risultato per la prova di funzionalità, ma è possibile modificarlo 🙂

    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
    • +1 per l’ottimizzazione grande, ma si potrebbe anche voler dichiarare la funzione del tipo di ritorno (presumo Stringa?).
    • Buona pesca – sicuramente dovrebbe dichiarare il tipo di ritorno. Dovrò provare, ma io ricordo di aver alcuni problemi quando ho provato a dichiarare (sembrava una variante).
    • In realtà, la “distanza” è un tipo Lungo in modo che il tipo di ritorno deve essere Lungo?
    • Risolto. Grazie, JP 🙂
    • La mia versione ha ~0.032 millisecondi per ogni chiamata. Il “ottimizzati” versione prende ~7.937, che è di circa 250 volte più lento. La rimozione di (inutile) dell’Applicazione.Screenupdating porta il tuo tempo per 0.422, solo 14 volte più lento. Sostituire il tuo (inutile) chiamata a Worksheetfunction.min con i miei MIN codice porta il tuo tempo a 0.032; di nuovo a dove abbiamo iniziato (ASC in realtà è leggermente più lento).
    • Grazie per il consiglio sorridendo l’uomo. Io sono d’accordo aggiornamento dello schermo è una cattiva scelta così ho eliminato. Cercherò in altri.
    • Pubblicare una soluzione che è il 10% più veloce e io rimuovere il -1 >;-)
    • Forse proverò 🙂 ho imparato un sacco di cose dal momento che questa risposta è stato pubblicato così posso sicuramente vedere dove ho potuto migliorare esso. 🙂 ciao
    • Ho trovato il migliore ottimizzazione è quello di decidere un min. % (come il 70% di partite o al di sopra) e facendo una lunghezza di controllo prima di eseguire il codice di base dal momento che la differenza di lunghezza vi dirà se è impossibile che si tratta di un 70%+ partita o no.
    • Bene, ora mi sono confuso….è questa versione ottimizzata più veloce o molto lento? È completamente chiaro, ma il mio intestino sensazione è che smirkingman è più corretto, perché egli comprende i numeri.
    • Il mio commento è rivolto Aevenko la versione iniziale, anni fa. Sembra che egli ha aggiornato la risposta di conseguenza. Migliore scommessa: prova da te >;-)

  3. 23

    Utilizzare una matrice di byte per 17x guadagno in velocità

      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
    • Questo cambiamento da una Stringa di Byte opere con le stringhe Unicode??
    • Prestazioni di implementazione è costantemente ~24x. Grande lavoro!
    • FYI, le persone che effettivamente cura su Unicode non può assumere il 2 ° byte è uguale a zero
  4. 15

    Credo ci sia stato anche più veloce… non ha fatto molto altro che migliorare il precedente codice di velocità e risultati %

    ' 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
    • Perché LCase()? L’algoritmo di Levenshtein è case sensitive. Questo è il punto.

Lascia un commento