Левенштейн Расстояние в VBA

Question

Левенштейн Расстояние в VBA

40

У меня есть лист Excel с данными, которые я хочу получить между ними. Я уже пытался экспортировать как текст, читать из script (php), запустить Levenshtein (рассчитать расстояние Левенштейна), сохранить его, чтобы снова преуспеть.

Но я ищу способ программно рассчитать расстояние Левенштейна в VBA. Как я могу это сделать?

Yousf 22 нояб. 2010, в 07:09

Источник

2

Почему такой невероятно полезный пост закрыт? Я слушал каждый подкаст SO, как он создавался, и, хотя это может быть в букве законов, это определенно не в духе того, почему SO был построен. Печальный.
tbone 21 июнь 2018, в 23:10
2

@tbone Согласен. Вопрос не требует усилий, но многие делают. И близкая причина настолько неправильна, насколько это может быть по моему мнению.
Andreas 07 авг. 2018, в 14:10

Теги:

vba

excel-vba

excel

levenshtein-distance

4 ответа

24

Спасибо smirkingman за хороший пост кода. Вот оптимизированная версия.

1) Вместо этого используйте Asc (Mid $(s1, i, 1). Числовое сравнение обычно быстрее, чем текст.

2) Используйте Mid $istead of Mid, так как позже это вариант ver. и добавление $- строка ver.

3) Используйте функцию приложения для мин. (только личное предпочтение)

4) Используйте Long вместо целых, поскольку он использует excel.

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

Для тех, кто этого хочет: я думаю, что можно с уверенностью сказать, что большинство людей используют расстояние Левенштейна для расчета нечетких совпадений. Вот способ сделать это, и я добавил оптимизацию, которую вы можете указать min. match% to return (по умолчанию 70%+. Вы вводите проценты, такие как "50" или "80", или "0" для запуска формулы независимо).

Ускорение скорости происходит из-за того, что функция проверяет, возможно ли это в том проценте, который вы даете, проверяя длину двух строк. Обратите внимание, что есть некоторые области, где эта функция может быть оптимизирована, но я сохранил ее для этого для удобства чтения. Я конкатенировал расстояние в результате для доказательства функциональности, но вы можете играть с ним:)

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

aevanko 21 июнь 2011, в 10:05

1

+1 для хорошей оптимизации, но вы также можете объявить тип возвращаемого значения функции (я полагаю, String?).
JimmyPena 09 нояб. 2011, в 13:28
0

Хороший улов - обязательно нужно указать тип возвращаемого значения. Мне придется попробовать, но я вспоминаю, что у меня были некоторые проблемы, когда я пытался объявить об этом (казалось, хотел вариант).
aevanko 09 нояб. 2011, в 14:01
0

На самом деле, «расстояние» является типом Long, поэтому тип возвращаемого значения должен быть Long?
JimmyPena 09 нояб. 2011, в 14:42
0

Исправлена. Спасибо, JP :)
aevanko 09 нояб. 2011, в 14:57
7

Моя версия занимает ~ 0,032 миллисекунды за звонок. Ваша «оптимизированная» версия занимает ~ 7,937, что примерно в 250 раз медленнее. Удаление (бесполезного) приложения. Обновление экрана сокращает время до 0,422, только в 14 раз медленнее. Замена вашего (бесполезного) вызова на Worksheetfunction.min моим кодом MIN сокращает ваше время до 0,032; вернуться к тому, с чего мы начали (ASC на самом деле немного медленнее).
smirkingman 16 нояб. 2011, в 11:36
0

Спасибо за совет ухмыляющегося человека. Я согласен, что обновление экрана - плохой выбор, поэтому я удалил его. Я посмотрю и на других.
aevanko 16 нояб. 2011, в 11:55
0

Опубликуйте решение, которое будет на 10% быстрее, и я удалю -1> ;-)
smirkingman 16 нояб. 2011, в 15:56
0

Возможно, я попробую :) Я многому научился с тех пор, как этот ответ был опубликован, поэтому я точно могу видеть, где я мог бы его улучшить. :) ура
aevanko 16 нояб. 2011, в 16:57
0

Я обнаружил, что лучшая оптимизация - это решение мин. % (например, совпадение 70% или выше) и выполнение проверки длины перед запуском основного кода, поскольку разница в длине покажет вам, невозможно ли это совпадение на 70% + или нет.
aevanko 22 нояб. 2011, в 00:06
0

@smirkingman Ну, теперь я в замешательстве .... эта оптимизированная версия быстрее или намного медленнее? Это совершенно не ясно, но мое внутреннее чувство таково, что ухмылка более правильная, потому что он включает числа.
tbone 21 июнь 2018, в 23:07
1

@tbone Мой комментарий обращался к первоначальной версии Аевенко много лет назад. Кажется, он обновил ответ соответственно. Лучшая ставка: проверить это самостоятельно> ;-)
smirkingman 26 июнь 2018, в 11:33

Показать ещё 9 комментариев

17

Использование байтового массива с коэффициентом усиления 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

Patrick OBeirne 20 июль 2012, в 19:34

0

Это изменение от String к Byte работает со строками Unicode ??
Raul Luna 15 июль 2013, в 07:41
0

Производительность вашей реализации постоянно ~ 24х. Отличная работа!
Austin D 18 дек. 2016, в 04:17
0

К вашему сведению, люди, которые на самом деле заботятся о Unicode, не могут предположить, что второй байт равен нулю
Gregor y 24 янв. 2019, в 06:30

Показать ещё 1 комментарий

14

Я думаю, что он еще быстрее... Не делал ничего, кроме улучшения предыдущего кода для скорости и результатов, поскольку%

' 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

Apostolos55 19 сен. 2012, в 12:35

1

Почему LCase() ? Алгоритм Левенштейна чувствителен к регистру. В этом-то и дело.
cprn 09 июнь 2016, в 11:53

Ещё вопросы

Почему такой невероятно полезный пост закрыт? Я слушал каждый подкаст SO, как он создавался, и, хотя это может быть в букве законов, это определенно не в духе того, почему SO был построен. Печальный.
@tbone Согласен. Вопрос не требует усилий, но многие делают. И близкая причина настолько неправильна, насколько это может быть по моему мнению.
+1 для хорошей оптимизации, но вы также можете объявить тип возвращаемого значения функции (я полагаю, String?).
Хороший улов - обязательно нужно указать тип возвращаемого значения. Мне придется попробовать, но я вспоминаю, что у меня были некоторые проблемы, когда я пытался объявить об этом (казалось, хотел вариант).
На самом деле, «расстояние» является типом Long, поэтому тип возвращаемого значения должен быть Long?
Моя версия занимает ~ 0,032 миллисекунды за звонок. Ваша «оптимизированная» версия занимает ~ 7,937, что примерно в 250 раз медленнее. Удаление (бесполезного) приложения. Обновление экрана сокращает время до 0,422, только в 14 раз медленнее. Замена вашего (бесполезного) вызова на Worksheetfunction.min моим кодом MIN сокращает ваше время до 0,032; вернуться к тому, с чего мы начали (ASC на самом деле немного медленнее).
Спасибо за совет ухмыляющегося человека. Я согласен, что обновление экрана - плохой выбор, поэтому я удалил его. Я посмотрю и на других.
Опубликуйте решение, которое будет на 10% быстрее, и я удалю -1> ;-)
Возможно, я попробую :) Я многому научился с тех пор, как этот ответ был опубликован, поэтому я точно могу видеть, где я мог бы его улучшить. :) ура
Я обнаружил, что лучшая оптимизация - это решение мин. % (например, совпадение 70% или выше) и выполнение проверки длины перед запуском основного кода, поскольку разница в длине покажет вам, невозможно ли это совпадение на 70% + или нет.
@smirkingman Ну, теперь я в замешательстве .... эта оптимизированная версия быстрее или намного медленнее? Это совершенно не ясно, но мое внутреннее чувство таково, что ухмылка более правильная, потому что он включает числа.
@tbone Мой комментарий обращался к первоначальной версии Аевенко много лет назад. Кажется, он обновил ответ соответственно. Лучшая ставка: проверить это самостоятельно> ;-)
Это изменение от String к Byte работает со строками Unicode ??
Производительность вашей реализации постоянно ~ 24х. Отличная работа!
К вашему сведению, люди, которые на самом деле заботятся о Unicode, не могут предположить, что второй байт равен нулю
Почему LCase() ? Алгоритм Левенштейна чувствителен к регистру. В этом-то и дело.

smirkingman · Accepted Answer · 2010-11-22T09-16-00.000Z

Перевод с 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

? Левенштейн ( "суббота", "воскресенье" )

3

Этот код работает перетаскивание для Access VBA тоже. :)
Краткое примечание для будущих пользователей, VBA Integer декларирует следует использовать меньше памяти и быстрее, но теперь они автоматически преобразуются в Long - типа за кулисами (источник: MSDN см это тоже). Так что для незначительного увеличения производительности, объявляя их всех как Long экономит время внутреннего преобразования (некоторые другие ответы, которые я вижу, воспользовались этим). ИЛИ, если длина ваших строк не превышает 255 символов, объявите их как Bytes как для этого требуется даже меньше памяти, чем для Integer .