Высчет Растояний Между Фразами

[synthex]

есть файл. там на листе 1 собраны ключевые запросы.Например, в столбце А запрос ремонт компьютеров. можно обратить внимание, что весь столбец А посути транспонирован в первой строке. Что мы видим? От фразы в столбце А ремонт компьютеров до фразы ремонт ноутбуков всего 1 шажок. т.к. он на следующей строчке. Теперь в столбце D фраза ремонт ноутбуков от нее до фразы ремонт компьюетров тоже 1 шаг. Т.е. эти фразы совстречаемы и разность между ними 1-1=0
На листе 4. выстроена квадратная матрица где эти понятия встречаются в ячейке vd522 вэ той ячейке стоит 0. Смотрим далее. на листе 1 от фразы ремонт компьютеров до фразы компьютерная помощь -2 шага. Смотрим столбец G компьютерная помощь до фразы ремонт комьютеров там 1 шаг: 2-1=1 цифра один вписывается в лист 4 в квадртаную матрицу эти понятия там встречаются в ячейки HZ 522, там ставим 1.
Если вдруг в одном столбце YYY есть фраза XXX, а в другом столбце от XXX нет фразы YYY то значит понятия не совстречаются и в квадратной матрице пустая ячейка. вообщем надо все так столбце проверить на совстречаемость и если она есть высчитать разность шагов по модулю и результат записать в матрице.
Как я эту задачу не решаю, у меня фигня получается. прикрепляю эксель
нас интересует макрос под кодовым названием Module1.CalcDist2

как это исправить
Прошу модераторов меня не бить за то что отправил файл с поддержкой макросов на файлобменник, он почему то у меня не прикрепляется
http://rghost.ru/57291850

[synthex]

решил сам код дать

Option Explicit
 
 
Sub CalcDist2() 'Мой код ( Антихакер32 )
    Dim Dic As Object, x&, y&, z&, x1&, y1&, v
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Dic = CreateObject("Scripting.Dictionary") 'Инициализация словаря
    Dic.CompareMode = vbTextCompare 'Сравнения без учета БОЛЬШИХ или маленьких букв
    Set Ws1 = Worksheets("Лист1") 'Ссылки на Лист1 и Лист4, для дальнейшего пользования
    Set Ws2 = Worksheets("Лист4")
    With Ws2 'Запись Y-колонки в словарь из второго листа
        For y = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            Dic.Add .Cells(y, 1).Value, y 'новое добавление ...Add([ключ],[значение])
        Next
    End With
    'просмотр 1-го листа
    With Ws1
        x1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For x = 1 To x1 'Перечисление всех колонок
            For y = 2 To .Cells(.Rows.Count, x).End(xlUp).Row 'Перечисление строк
                v = .Cells(y, x) 'Следующее значение ячейки 1-го листа
                For z = x + 1 To x1 'поиск соответствия по верхней строке
                    If v = .Cells(1, z) Then
                        'Запись в матрицу второго листа
                        Ws2.Cells(Dic(v), z) = Abs(y - z)
                        Exit For 'Выход из цикла поиска соответствий
                    End If
        Next: Next: Next
    End With
End Sub
 
 
 
Sub CalcDist()
    Dim iCl1%, iCl2%, iRw1%, iRw2%, sNmCl1$, sNmCl2$
    Dim lLr%, i%
 
    Dim oDict: Set oDict = CreateObject("Scripting.Dictionary"): oDict.CompareMode = vbBinaryCompare
    On Error Resume Next
    If IsError(Worksheets(2)) Then Sheets.Add 'Добавляем новый лист
    On Error GoTo 0
    
    With Worksheets(2)
 
        lLr = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lLr
            oDict.Item(.Cells(i, 1).Value) = i
        Next i
    End With
 
    For iCl1 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column - 3 Step 3  ' направо
        iCl2 = iCl1 + 3
        sNmCl1 = Cells(1, iCl1).Value
        sNmCl2 = Cells(1, iCl2).Value
        iRw1 = 0: iRw2 = 0
        
        For i = 2 To Cells(Rows.Count, iCl1).End(xlUp).Row
            If sNmCl2 = Cells(i, iCl1).Value Then
                iRw1 = i
            End If
        Next i
        For i = 2 To Cells(Rows.Count, iCl2).End(xlUp).Row
            If sNmCl1 = Cells(i, iCl2).Value Then
                iRw2 = i
            End If
        Next i
 
        If iRw1 <> 0 And iRw2 <> 0 Then
            Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
        Else
             Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6
        End If
 
 
    Next iCl1
 
    For iCl1 = Cells(1, Columns.Count).End(xlToLeft).Column - 1 To 2 Step -3    ' налево
        iCl2 = iCl1 - 3
        sNmCl1 = Cells(1, iCl1).Value
        sNmCl2 = Cells(1, iCl2).Value
        iRw1 = 0: iRw2 = 0
        For i = 2 To Cells(Rows.Count, iCl1).End(xlUp).Row
            If sNmCl2 = Cells(i, iCl1).Value Then
                iRw1 = i
            End If
        Next i
        For i = 2 To Cells(Rows.Count, iCl2).End(xlUp).Row
            If sNmCl1 = Cells(i, iCl2).Value Then
                iRw2 = i
            End If
        Next i
 
        If iRw1 <> 0 And iRw2 <> 0 Then
            Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
        Else
             Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6
        End If
    Next iCl1
End Sub