Аргументы: 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 по подстрокам длины 1. |
t |
t, e, x, t |
да |
3 |
4 |
e |
t, e, x, t |
да |
s |
t, e, x, t |
нет |
t |
t, e, x, t |
да |
Сравниваем строку text со строкой test по подстрокам длины 1. |
t |
t, e, s, t |
да |
3 |
4 |
e |
t, e, s, t |
да |
x |
t, e, s, t |
нет |
t |
t, e, s, t |
да |
Сравниваем строку test со строкой text по подстрокам длины 2. |
te |
te, ex, xt |
да |
1 |
3 |
es |
te, ex, xt |
нет |
st |
te, ex, xt |
нет |
Сравниваем строку text со строкой test по подстрокам длины 2. |
te |
te, es, st |
да |
1 |
3 |
ex |
te, es, st |
нет |
xt |
te, es, st |
нет |
Сравниваем строку test со строкой text по подстрокам длины 3. |
tes |
tex, ext |
нет |
0 |
2 |
est |
tex, ext |
нет |
Сравниваем строку text со строкой test по подстрокам длины 3. |
tex |
tes, est |
нет |
0 |
2 |
ext |
tes, est |
нет |
Сравниваем строку test со строкой text по подстрокам длины 4. |
test |
text |
нет |
0 |
1 |
Сравниваем строку text со строкой test по подстрокам длины 4. |
text |
test |
нет |
0 |
1 |
Итого |
8 |
20 |
Приведённая таблица иллюстрирует алгоритм подсчёта коэффициента схожести двух строк. Для строк "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 ...