Levenshtein en VBA

J'ai une feuille excel avec les données que je veux obtenir de Levenshtein entre eux. J'ai déjà essayé d'exporter en tant que texte, lu à partir d'un script (php), exécution de Levenshtein (calculer la Distance de Levenshtein), l'enregistrer dans excel.

Mais je suis à la recherche d'un moyen de par programmation à calculer une Distance de Levenshtein en VBA. Comment pourrais-je aller sur le faire?

Pourquoi une telle incroyablement utile post fermé? J'ai écouté tous les podcast, comme il était en cours de construction, et bien que cela puisse être dans la lettre de la loi, ce n'est certainement pas dans l'esprit de pourquoi a été construit. Triste.
D'accord. La question ne dispose pas d'un effort, mais beaucoup le font. Et de la raison en est que de mal car il peut être, à mon avis.

InformationsquelleAutor Yousf | 2010-11-22

Traduit de l' Wikipédia :

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("samedi","dimanche")

Ce code fonctionne glisser-déposer pour l'Accès VBA trop. 🙂
Note rapide pour les futurs utilisateurs, VBA Integer déclare doit utiliser moins de mémoire et d'être plus rapides, mais ils sont maintenant automatiquement converties en Long type coulisses (source: MSDN sur ceci trop). Donc, pour marginal de l'augmentation de la performance, les déclarant tous comme Long enregistre sur la conversion interne de temps (de quelques autres réponses je vois ont fait usage de cette). OU, si vos cordes sont en vertu de 255 caractères, déclarer que Bytes car cela nécessite moins de mémoire que Integer.

InformationsquelleAutor smirkingman

29

Grâce à smirkingman pour le bon code postal. Ici est une version optimisée.

1) l'Utilisation de l'Asc(Mid$(s1, i, 1) à la place. Numérique comparaison est généralement plus rapide que le texte.

2) Utilisez Mid$ istead de Milieu des depuis le, plus tard, est la variante du ver. et en ajoutant $ est la chaîne de ver.

3) l'Utilisation de fonction d'application pour min. (préférence personnelle uniquement)

4) l'Utilisation d'Entiers puisque c'est ce qu'excel utilise en mode natif.
```
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
```
Mise à JOUR:

Pour ceux qui le veulent: je pense qu'il est sûr de dire que la plupart des gens utilisent Levenshtein pour calculer correspondance floue pourcentages. Voici une façon de le faire, et j'ai ajouté une optimisation que vous pouvez spécifier le min. match % de retour (la valeur par défaut est de 70%+. Vous entrez percentags comme "50" ou "80", ou "0" pour exécuter la formule, peu importe).

Le boost de vitesse vient du fait que la fonction va vérifier si il est même possible que c'est le pourcentage de la donner par la vérification de la longueur des 2 chaînes. A noter qu'il existe certains domaines où cette fonction peut être optimisé, mais j'ai gardé ce par souci de lisibilité. J'ai concaténé la distance dans le résultat pour la preuve de la fonctionnalité, mais vous pouvez jouer avec elle 🙂
```
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 pour la grande optimisation, mais vous pouvez également déclarer la fonction de type de retour (je suppose Chaîne?).
- Bon catch - devrait certainement déclarer le type de retour. Je vais essayer, mais je me souviens d'avoir quelques problèmes quand j'ai essayé de le déclarer (a semblé vouloir une variante).
- En fait, la "distance" est un type Long de sorte que le type de retour doit être Long?
- Ma version prend ~0.032 millisecondes par appel. Votre 'optimisé' version prend ~7.937, qui est d'environ 250 fois plus lent. Retrait (inutiles) de l'Application.Screenupdating apporte votre temps à 0.422, à seulement 14 fois plus lent. Le remplacement de votre (inutile) appel à Worksheetfunction.min avec mon code MIN apporte votre temps à 0.032; retour à où nous avons commencé (ASC est en fait légèrement plus lent).
- Merci pour les conseils sourire l'homme. Je suis d'accord la mise à jour écran est un mauvais choix donc je l'ai supprimé. Je vais regarder dans les autres.
- Publier une solution qui est de 10% plus vite et je vais supprimer l'-1 >;-)
- Peut-être que je vais essayer 🙂 j'ai appris beaucoup de choses depuis cette réponse a été posté donc je peux certainement voir où je pourrais avoir de l'améliorer. 🙂 cheers
- J'ai trouvé la meilleure optimisation est de décider d'un min. % (70% correspond à ou au-dessus) et de faire un contrôle de la longueur avant d'exécuter le code de base, puisque la différence de longueur est vous dire si c'est impossible, que c'est un 70%+ match ou pas.
- Eh bien maintenant, je suis confus....est-ce la version optimisée plus rapide ou beaucoup plus lentement? C'est pas du tout clair, mais mon impression est que smirkingman est plus correcte car il inclut des nombres.
- Mon commentaire concernait Aevenko de la version initiale, il y a des années. Il me semble qu'il a mis à jour la réponse en conséquence. Meilleur résultat: test vous-même >;-)
InformationsquelleAutor aevanko

Utiliser un tableau d'octets pour 17x gain de vitesse

  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

Ce changement de Chaîne d'Octets fonctionne avec des chaînes Unicode??
Les performances de votre application est constamment ~24x. Magnifique travail!!!
Pour info, les gens qui se soucient réellement de l'Unicode ne pouvez pas assumer la 2e octet est égal à zéro

InformationsquelleAutor Patrick OBeirne

Je pense que c'est encore plus rapide... n'a pas faire beaucoup plus que de l'améliorer de code précédent pour la vitesse et les résultats en %

' 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

Pourquoi LCase()? L'algorithme de Levenshtein est sensible à la casse. C'est le point.

InformationsquelleAutor Apostolos55

Vous devez vous connecter pour publier un commentaire.