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

Тема в разделе "Visual Basic", создана пользователем psychologist, 5 авг 2014.

  1. psychologist

    psychologist New Member

    Регистрация:
    9 апр 2012
    Сообщения:
    2
    Симпатии:
    0
    Уже который день не могу решить такую задачу.
    есть файл.
    там на листе 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


    вот он сам
    Код (LotusScript):
    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
    может вы подскажите как быть. обратите вниманеи, что там надо просматривать между всеми столбцами совстречаемость фраз их там много.
    Прошу модераторов меня не бить за то что отправил файл с поддержой макросов на файлобменник, он почему то у меня не прикрепляется
    http://rghost.ru/57291850
     
  2. Frenzo

    Frenzo New Member

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

Поделиться этой страницей