Сравнение строк как нетривиальная задача

For line_num_A = 2 To end_a   - проход всего списка А
    name_length = Len(Cells(line_num_A, 1)) - длина названия А   
    For line_num_B = 2 To end_B - проход списка Б
        y = 0
        For k = 1 To name_lenght - 1 проход по буквам названия из списка А
            text_comp = Mid(Cells(list_num_A, 1), k, 2) - получение послед-но двух букв из названия А
            res = Cells(list_num_B, 3).Text Like '*' & text1 & '*' - сравнение каждого наименования из 'Б' с очередными 2-мя буквами из названия в 'А'.
            If res = True Then y = y + 1
        Next
    Next
Next

Option Compare Database
Option Explicit
Public cnn  As ADODB.Connection
Public rst  As New ADODB.Recordset
Public strSQL As String
Public dDate As Date
 
   
Public Function InsertFiles() As Long
 
'Error-handler inserted on 13.02.2005 at 18:19 by Dedushev M.N.
'
On Error GoTo InsFil_Error
 
   Dim iTimer As Long
   iTimer = Timer
   Set cnn = CurrentProject.Connection
      cnn.Execute 'DELETE * FROM Main_Tmp'
      Call InsertFileInTmp('admnar8')
      Call InsertFileInTmp('admnar9')
      
      InsertFiles = Timer - iTimer
   cnn.Close
   
 
InsFil_Exit:
Exit Function
 
InsFil_Error:
MsgBox 'Непредвиденная разработчиком ошибка - ' & Err.Number & vbCrLf & vbCrLf & Error$, vbExclamation, 'admnar - InsFil'
Resume InsFil_Exit
 
End Function
 
Public Function InsertFileInTmp(strFile As String) As Boolean
 
'Error-handler inserted on 13.02.2005 at 18:19 by Dedushev M.N.
'
On Error GoTo InsFilInTmp_Error
 
   Dim bPos As Byte, idRajon As Integer
   Dim fld As ADODB.Field, idStatja As Integer
   rst.Open strFile, cnn, adOpenKeyset, adLockReadOnly
      rst.AbsolutePosition = 5
      bPos = IIf(InStr(rst.Fields(0), 'ГАИ + ПДПС') > 0, 16, 14)
      rst.AbsolutePosition = 7
      dDate = rst.Fields(1)
      
      strSQL = 'SELECT Count (*) FROM Main WHERE DateReport = #'
      strSQL = strSQL & Format(dDate, 'mm/dd/yy') & '#'
      If CLng(cnn.Execute(strSQL).GetString) > 0 Then GoTo InsFilInTmp_Exit
      
      rst.AbsolutePosition = bPos
      Do Until rst.EOF
         idRajon = GetIdByTextRajon(rst.Fields(0))
         If idRajon <> 0 Then
            For Each fld In rst.Fields
               idStatja = GetIdByTextStatja(fld.Name)
               If idStatja <> 0 Then
                  strSQL = 'Insert Into Main_Tmp (DateReport, Rajon, '
                  strSQL = strSQL & 'Statja, Summa) Select ''
                  strSQL = strSQL & dDate & '','' & idRajon & '',''
                  strSQL = strSQL & idStatja & '','' & Nz(fld, 0) & '''
                  cnn.Execute strSQL
               End If
            Next fld
         End If
         rst.MoveNext
      Loop
 
InsFilInTmp_Exit:
rst.Close
Exit Function
 
InsFilInTmp_Error:
MsgBox 'Непредвиденная разработчиком ошибка - ' & Err.Number & vbCrLf & vbCrLf & Error$, vbExclamation, 'admnar - InsFilInTmp'
Resume InsFilInTmp_Exit
 
End Function
 
Public Function GetIDMaxArrValue() As Long
 
'Error-handler inserted on 18.02.2005 at 07:54 by Dedushev M.N.
'
On Error GoTo GetIDMaxArrVal_Error
 
   Dim arr, i As Integer, maxA As Long, strArr As String
   Dim strReplace As String
   arr = Array(1, 10, 2, 25, 3, 35, 4, 11)
Begin_Process:
   For i = 1 To UBound(arr) Step 2
      If arr(i) > arr(maxA) Then
         maxA = i
      End If
   Next i
   Select Case MsgBox('Совпадений - ' & arr(maxA), _
                                    vbQuestion + vbYesNoCancel)
      ' Вместо 'Совпадений - ' ляляля -

Public Function GetIDMaxArrValue() As Long
 
'Error-handler inserted on 18.02.2005 at 07:54 by Dedushev M.N.
'
On Error GoTo GetIDMaxArrVal_Error
 
Dim arr, i As Integer, maxA As Long, strArr As String
Dim strReplace As String
arr = Array(1, 10, 2, 25, 3, 35, 4, 11)
Begin_Process:
For i = 1 To UBound(arr) Step 2
If arr(i) > arr(maxA) Then
maxA = i
End If
Next i
Select Case MsgBox('Совпадений - ' & arr(maxA), _
vbQuestion + vbYesNoCancel)
' Вместо 'Совпадений - ' ляляля - вставь что тебе нужно
Case vbYes
GetIDMaxArrValue = maxA
GoTo GetIDMaxArrVal_Exit
Case vbNo
strArr = Join(arr, ';')
strReplace = arr(maxA - 1) & ';' & arr(maxA) & ';'
strArr = Replace(strArr, strReplace, '')
arr = Split(strArr, ';')
GoTo Begin_Process
Case vbCancel
GoTo GetIDMaxArrVal_Exit
End Select
 
GetIDMaxArrVal_Exit:
Exit Function
 
GetIDMaxArrVal_Error:
MsgBox 'Непредвиденная разработчиком ошибка - ' & _
Err.Number & vbCrLf & vbCrLf & Error$, vbExclamation, _
'admnar - GetIDMaxArrVal'
Resume GetIDMaxArrVal_Exit
 
End Function