Алгоритм нечёткого сравнения

Алгоритм нечёткого сравнения

Связать^?

Алгоритм нечёткого сравнения использует в качестве аргументов две строки и параметр сравнения — максимальную длину сравниваемых подстрок.

Результатом работы алгоритма является число, лежащее в пределах от 0 до 1. 0 соответствует полному несовпадению двух строк, а 1 их полной (в определенном ниже смысле) идентичности.

Алгоритм

Функция сравнения составляет все возможные комбинации подстрок с длиной вплоть до указанной (если длина 0 или есть строка с длиной меньше указанной длины, то выбирается минимальная длина строк) и подсчитывает их совпадения в двух сравниваемых строках. Количество совпадений, разделенное на число вариантов объявляется коэффициентом схожести строк и выдается в качестве результата работы функции.

'Аргументы: 
'  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 - полной (в определённом ниже смысле) их идентичности. Сравнение строк происходит по следующей схеме. Увеличение длины максимальной подстроки незначительно увеличивает время работы функции (вообще, следует заметить, что сравнение выполняется достаточно быстро). С другой стороны, поиск становится более чётким. Пожалуй, оптимального значения длины максимальной подстроки нет, но я рекомендую задавать его равным 2-3-4.

Пример:
1. Сравнение с учетом регистра

If IndistinctMatching(4, "test", "TEXT", vbBinaryCompare) > 40 Then ... 

2. Сравнение без учета регистра

If IndistinctMatching(4, "test", "TEXT", vbTextCompare) > 40 Then ...