?CStr(Round(CompStr("Иванов","Ивонов")* 100 ))+"%"
 60 %
?CStr(Round(CompStr("Иванов","Ивнов")* 100 ))+"%"
 53 %
?CStr(Round(CompStr("Иванов","Петров")* 100 ))+"%"
 20 %
?CStr(Round(CompStr("Иванов","Люся")* 100 ))+"%"
 0 %
?CStr(Round(CompStr("Иванов","Иванов")* 100 ))+"%"
 100 %

Function CompStr(Str1 As String, Str2 As String) As Single

Dim Word As Integer, likeness As Long, i As Integer
Dim maxn As Integer, k As Integer
Dim s1 As String, s2 As String
Word =  3 : likeness =  0 
s1 = Trim(CutDblSpaces(IIf(Len(Str1) > Len(Str2), Str1, Str2)))
s2 = Trim(CutDblSpaces(IIf(Len(Str1) > Len(Str2), Str2, Str1)))

If Len(s1) < Word +  1  Or Len(s2) < Word +  1  Then
  CompStr = IIf(s1 = s2,  1 ,  0 )
  Exit Function
End If

For i =  1  To Len(s1) - Word +  1 
  maxn =  0 
  k = InStr( 1 , s2, Mid$(s1, i, Word))
  Do Until k =  0 
    If Len(s1) - Abs(k - i) > maxn Then maxn = Len(s1) - Abs(k - i)
    k = InStr(k +  1 , s2, Mid$(s1, i, Word))
  Loop
  likeness = likeness + maxn
Next
CompStr = likeness / (Len(s1) * (Len(s1) - Word +  1 ))
  
End Function

?CStr(Round(CompStr("Иванов","воновИ")* 100 ))+"%"