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

[psychologist]

Уже который день не могу решить такую задачу.
есть файл.
там на листе 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


вот он сам

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

может вы подскажите как быть. обратите вниманеи, что там надо просматривать между всеми столбцами совстречаемость фраз их там много.
Прошу модераторов меня не бить за то что отправил файл с поддержой макросов на файлобменник, он почему то у меня не прикрепляется

Ссылка скрыта от гостей

 

[Frenzo]

Наро я в шоке что творит наше правительство.... Такое впечатление буд- то за нами следят, даже началась работа пилотного проекта о передаче сведений о кассовых операциях, вот ознакомьтесь www.modber.ru/news/nachalas-rabota-pilotnogo-proekta-o-peredache-svedenii-o-kasovyh-operacijah.html