Нечеткое сравнение строк

Аргументы: lngMaxLen - максимальная длина сравниваемых подстрок (читайте описание алгоритма сравнения строк), strStringMatching- первая строка, strStringStandart - вторая строка, lngCase - тип сравнения (с учётом регистра или без учёта)
Назначение: Нечеткое сравнение двух строк
Возвращает: Возвращает коэффициент совпадения строк от 0 до 100 ( 0 - строки не совпадают, 100 - полное совпадение).

Public Type RetCount
lngSubRows As Long
lngCountLike As Long
End Type

Public Function IndistinctMatching(lngMaxLen As Long, strStringMatching As String, strStringStandart As String, lngCase As Long) As Long
Dim gret As RetCount
Dim tret As RetCount
Dim lngCurLen As Long 

If lngMaxLen = 0 Or Len(strStringMatching) = 0 Or Len(strStringStandart) = 0 Then
    IndistinctMatching = 0
    Exit Function
End If
gret.lngCountLike = 0
gret.lngSubRows = 0
For lngCurLen = 1 To lngMaxLen
    tret = MatchingStrings(strStringMatching, strStringStandart, lngCurLen, lngCase)
    gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
    gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
    tret = MatchingStrings(strStringStandart, strStringMatching, lngCurLen, lngCase)
    gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
    gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
Next lngCurLen
If gret.lngSubRows = 0 Then
    IndistinctMatching = 0
    Exit Function
End If
IndistinctMatching = (gret.lngCountLike / gret.lngSubRows) * 100
End Function

Public Function MatchingStrings(strA As String, strB As String, lngLen As Long, lngCase As Long) As RetCount
Dim tret As RetCount
Dim y As Long, z As Long
Dim strta As String
Dim strtb As String

For z = 1 To Len(strA) - lngLen + 1
    strta = Mid(strA, z, lngLen)
    y = 1
    For y = 1 To Len(strB) - lngLen + 1
        strtb = Mid(strB, y, lngLen)
        If StrComp(strta, strtb, lngCase) = 0 Then
            tret.lngCountLike = tret.lngCountLike + 1
            Exit For
        End If
    Next y
    tret.lngSubRows = tret.lngSubRows + 1
Next z
MatchingStrings.lngCountLike = tret.lngCountLike
MatchingStrings.lngSubRows = tret.lngSubRows
End Function

Алгоритм сравнения строк
Функция нечёткого сравнения использует в качестве аргументов две строки и параметр сравнения - максимальную длину сравниваемых подстрок. Результатом работы функции является число, лежащее в пределах от 0 до 1. 0 соответствует полному несовпадению двух строк, а 1 - полной (в определённом ниже смысле) их идентичности.
Сравнение строк происходит по следующей схеме. Пусть, например, в качестве аргументов заданы две строки "test" и "text" и некоторая максимальная длина подстрок, скажем, 4. Функция сравнения составляет все возможные комбинации подстрок с длинной вплоть до указанной и подсчитывает их совпадения в двух сравниваемых строках. Количество совпадений, разделённое на число вариантов, объявляется коэффициентом схожести строк и выдаётся в качестве результата работы функции.

Продолжим пример.

Приведённая таблица иллюстрирует алгоритм подсчёта коэффициента схожести двух строк. Для строк "test" и "text" и длины максимальной подстроки, равной 4, мы получили значения коэффициента, равное 8/20, то есть 0,4. Если ограничиться подстроками меньшей длины, то мы будем получать другие коэффициенты: например, для подстрок единичной длины результатом будет 6/8 или 0,75. Заметим, что если в качестве длины максимальной подстроки задавать значения, большие 4, результат не будет изменяться: в самом деле, ведь в указанных строках нет подстрок большей длины.
Увеличение длины максимальной подстроки незначительно увеличивает время работы функции (вообще, следует заметить, что сравнение выполняется достаточно быстро). С другой стороны, поиск становится более чётким. Пожалуй, оптимального значения длины максимальной подстроки нет, но я рекомендую задавать его равным 2-3.

Пример:
1. Сравнение с учетом регистра
If IndistinctMatching(4, "test", "TEXT", vbBinaryCompare) > 40 Then ...
2. Сравнение без учета регистра
If IndistinctMatching(4, "test", "TEXT", vbTextCompare) > 40 Then ...

• Обратиться в "Интерфейс" за дополнительной информацией/по вопросу приобретения продуктов
• Подписаться на рассылку "Программирование на Microsoft Access"