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

Option Explicit

Public Function Compare(ByVal s As String, ByVal sOrig As String, Optional ByVal lLength As Long) As Double
    Compare = fStatL(s, sOrig, lLength)
End Function

Private Function fStatL(ByVal s As String, ByVal sOrig As String, ByVal lLength As Long) As Double
If Len(s) < lLength Or Len(sOrig) < lLength Or lLength =  0  Then If Len(s) < Len(sOrig) Then lLength = Len(s) Else lLength = Len(sOrig)

Dim l As Long
Dim lHits As Long
Dim lCount As Long
For l =  1  To lLength
    lHits = lHits + fStatIn(s, sOrig, l)
    lCount = lCount + Len(s) + Len(sOrig) -  2  * l +  2 
Next l
If lCount =  0  Then fStatL =  0  Else fStatL = lHits / lCount
End Function

Private Function fStatIn(ByVal s As String, ByVal sOrig As String, ByVal lLength As Long) As Long
Dim l As Long
For l =  1  To Len(s) - lLength +  1 
    If Not InStr(sOrig, Mid(s, l, lLength)) =  0  Then fStatIn = fStatIn +  1 
Next l

For l =  1  To Len(sOrig) - lLength +  1 
    If Not InStr(s, Mid(sOrig, l, lLength)) =  0  Then fStatIn = fStatIn +  1 
Next l
End Function