Поиск похожего звучащего текста в VBA

Мой менеджер говорит мне, что есть способ оценить имена, которые написаны по-разному, но звучат похоже в том, как они произносятся. В идеале мы хотим иметь возможность оценивать введенное пользователем имя поиска и возвращать точные совпадения, а также имена с похожим звучанием. Он назвал процесс "Soundits", но я не могу найти какую-либо информацию в Google.

Это существует? Кто-нибудь знает, доступен ли он для VBA (Access)?

Источник

5 ответов

Решение

Хороший вопрос! Ваш вопрос включает в себя отличный пример самой идеи.

Существует алгоритм, называемый алгоритмом Рассела Саундекса, стандартная техника во многих приложениях, которая оценивает имена по фонетическому, а не по фактическому написанию. В этом вопросе Soundits и Soundex - похожие названия! [Редактировать: просто запустить Soundex. Soundits=S532 и Soundex=S532.]

О Soundex:

Алгоритм Soundex основан на характеристиках английского языка, таких как:

  1. Первая буква имеет большое значение
  2. Многие согласные звучат похоже
  3. Согласные влияют на произношение больше, чем гласные

Одно предупреждение: Soundex был разработан для имен. Чем короче, тем лучше. Поскольку имя растет дольше, Soundex становится менее надежным.

Ресурсы:

  1. Вот пример, который использует VBA для доступа.
  2. Есть запись о Soundex в Руководстве для разработчиков VBA, второе издание Кена Гетца и Майка Гилберта.
  3. Существует много информации о Soundex и других вариантах, таких как Soundex2 (поиск "Soundex" и "VBA").

Пример кода:

Ниже приведен код VBA, найденный с помощью быстрого веб-поиска, который реализует разновидность алгоритма Soundex.

Option Compare Database
Option Explicit

Public Function Soundex(varText As Variant) As Variant
On Error GoTo Err_Handler
    Dim strSource As String
    Dim strOut As String
    Dim strValue As String
    Dim strPriorValue As String
    Dim lngPos As Long

    If Not IsError(varText) Then
        strSource = Trim$(Nz(varText, vbNullString))
        If strSource <> vbNullString Then
            strOut = Left$(strSource, 1&)
            strPriorValue = SoundexValue(strOut)
            lngPos = 2&

            Do
                strValue = SoundexValue(Mid$(strSource, lngPos, 1&))
                If ((strValue <> strPriorValue) And (strValue <> vbNullString)) Or (strValue = "0") Then
                    strOut = strOut & strValue
                    strPriorValue = strValue
                End If
                lngPos = lngPos + 1&
            Loop Until Len(strOut) >= 4&
        End If
    End If

    If strOut <> vbNullString Then
        Soundex = strOut
    Else
        Soundex = Null
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "Soundex()"
    Resume Exit_Handler
End Function
Private Function SoundexValue(strChar As String) As String
    Select Case strChar
    Case "B", "F", "P", "V"
        SoundexValue = "1"
    Case "C", "G", "J", "K", "Q", "S", "X", "Z"
        SoundexValue = "2"
    Case "D", "T"
        SoundexValue = "3"
    Case "L"
        SoundexValue = "4"
    Case "M", "N"
        SoundexValue = "5"
    Case "R"
        SoundexValue = "6"
    Case vbNullString
        SoundexValue = "0"
    Case Else
        'Return nothing for "A", "E", "H", "I", "O", "U", "W", "Y", non-alpha.
    End Select
End Function

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

Другой метод сравнения строк - получить расстояние Левенштейна. Вот пример, приведенный в VBA, он взят из LessThanDot Wiki:

Function LevenshteinDistance(word1, word2)

Dim s As Variant
Dim t As Variant
Dim d As Variant
Dim m, n
Dim i, j, k
Dim a(2), r
Dim cost

   m = Len(word1)
   n = Len(word2)

   ''This is the only way to use
   ''variables to dimension an array
   ReDim s(m)
   ReDim t(n)
   ReDim d(m, n)

   For i = 1 To m
       s(i) = Mid(word1, i, 1)
   Next

   For i = 1 To n
       t(i) = Mid(word2, i, 1)
   Next

   For i = 0 To m
       d(i, 0) = i
   Next

   For j = 0 To n
       d(0, j) = j
   Next


   For i = 1 To m
       For j = 1 To n

           If s(i) = t(j) Then
               cost = 0
           Else
               cost = 1
           End If

           a(0) = d(i - 1, j) + 1             '' deletion
           a(1) = d(i, j - 1) + 1             '' insertion
           a(2) = d(i - 1, j - 1) + cost      '' substitution

           r = a(0)

           For k = 1 To UBound(a)
               If a(k) < r Then r = a(k)
           Next

           d(i, j) = r

       Next

   Next

   LevenshteinDistance = d(m, n)

End Function
Источник

Вот пара рабочих примеров алгоритма SOUNDEX в VBA:

Источник

В дополнение к Soundex, который часто дает вам слишком слабое совпадение, чтобы быть действительно полезным, вы должны также взглянуть на Soundex2 (вариант Soundex, который является более гранулированным), и на другой тип соответствия, Simil(). Я использую все три.

Источник

Вы ищете SOUNDEX.

Источник

Также рассмотрите возможность использования первых двух или трех букв имени и фамилии. В базе данных, в которой было 10000 имен, Джо См (Джо / Джон / Джоан Смит) вернула только три или четыре записи.

Также какой тип имен. Собираетесь ли вы получить людей, использующих сокращенную версию? Например, мое официальное имя - Энтони, но меня всегда зовут Тони.

Источник
Другие вопросы по тегам