Levenshtein Khoảng cách trong VBA

Question

Tôi có bảng excel với dữ liệu mà tôi muốn để có được Levenshtein Khoảng cách giữa chúng. Tôi đã cố gắng để xuất khẩu như văn bản, đọc trong từ kịch bản (php), chạy Levenshtein (tính Levenshtein Distance), lưu nó vào excel một lần nữa.

Nhưng tôi đang tìm cách tính toán khoảng cách Levenshtein theo chương trình trong VBA. Làm thế nào tôi sẽ đi về làm như vậy?

Answer 1

dịch từ 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 ("thứ bảy", "chủ nhật")

Answer 2

Nhờ smirkingman cho mã bưu tốt đẹp. Đây là một phiên bản được tối ưu hóa.

1) Sử dụng Asc (Mid $ (s1, i, 1) để thay thế. So sánh bằng số thường nhanh hơn so với văn bản.

2) Sử dụng trung $ istead của trung kể từ sau là phiên bản ver. và thêm $ là chuỗi ver.

3) Sử dụng chức năng ứng dụng cho phút. (chỉ sở thích cá nhân)

4) Sử dụng Dài thay vì Số nguyên vì đó là những gì excel sử dụng nguyên bản.

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 

CẬP NHẬT:

Đối với những người muốn nó: Tôi nghĩ rằng nó an toàn để nói rằng hầu hết mọi người sử dụng khoảng cách levenshtein để tính toán tỷ lệ phần trăm trận đấu mờ. Đây là một cách để làm điều đó, và tôi đã thêm một tối ưu hóa mà bạn có thể chỉ định min. khớp% để trả về (mặc định là 70% +. Bạn nhập phần trăm như "50" hoặc "80" hoặc "0" để chạy công thức bất kể).

Tốc độ tăng lên đến từ thực tế là chức năng sẽ kiểm tra xem có thể là nó nằm trong tỷ lệ phần trăm bạn đưa ra bằng cách kiểm tra độ dài của 2 chuỗi. Xin lưu ý có một số lĩnh vực mà chức năng này có thể được tối ưu hóa, nhưng tôi đã giữ nó ở đây vì mục đích dễ đọc. Tôi nối khoảng cách trong kết quả cho bằng chứng về chức năng, nhưng bạn có thể fiddle với nó :)

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

Sử dụng một mảng byte cho 17 lần tốc độ tăng

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

tôi nghĩ rằng nó đã nhanh hơn rất ... Không làm được gì khác ngoài việc cải thiện mã trước đó cho tốc độ và kết quả dưới dạng%

' 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