'-- алгоритм нечеткого сравнения строк
Option Compare Database
Option Explicit

Public Type RetCount
lngSubRows As Long
lngCountLike As Long
End Type

'IndistinctMatching(12, "text", "TEXT",vbTextCompare) ', vbBinaryCompare
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