Страницы: 1
RSS
Поиск слов в списке фраз по списку неточных соответствий, ускорение процесса поиска
 
Здравствуйте ув. форумчане. прощу помощи.


Прикладываю пример, прощу взгляните. И дайте какие то подсказки.. как можно ускорить процесс проверки 1 столбца на совпадение.

Дело в том что.. в 1 столбце вставляются фразы а в правом уже вставляется то, что нужно найти в 1.. и в правом столбце довольно много слов нужно прописывать.. и вот это дело тормозит неслыханно.. в примере около 500 слов.. это в среднем столько бывает.. но этому макросу сложно и 10 слов обработать.. тоже очень долго.

В левом столбце тоже объем довольно большим бывает.

Подскажите пожалуйста.. как можно доработать или переделать макрос... что бы обрабатывалось все это дело быстро.
Изменено: Gagarin13 - 14.10.2018 22:43:38
 
Gagarin13, Что бросается в глаза, так это то, что если даже уже строка помечена (добавлена в массив rr) её все равно терзаете для других значений.
Я б поменял  циклы местами перебирая во внешнем цикле то что удаляем, при этом из второго цикла выходить при найденном совпадении.
Код
    For li = 1 To lLastRow 'öèêë ñ ïåðâîé ñòðîêè äî êîíöà
        For lr = 1 To UBound(avArr, 1)
            If InStr(1, arr(li, 1), avArr(lr, 1), 1) > 0 Then
                If rr Is Nothing Then
                    Set rr = Cells(li, 1)
                Else
                    Set rr = Union(rr, Cells(li, 1))
                End If
                Exit For
            End If
            DoEvents
        Next
        DoEvents
    Next
Изменено: БМВ - 14.10.2018 23:10:06
По вопросам из тем форума, личку не читаю.
 
Чёт не очень получается ускорить...
Но вот подумайте над данными - например там есть такое:
букет
букета
букетах
букетик
букетов
букеты

Вот зачем искать 5 последующих, если уже искали первое?
Изменено: Hugo - 14.10.2018 23:16:50
 
Цитата
БМВ написал: ...если даже уже строка помечена (добавлена в массив rr) её все равно терзаете для других значений.
Про это я как раз догадывался.. что те 500 слов обрабатывает на каждую ячейку..вот только реализовать в коде VB я не горазд по нормальному.

Цитата
БМВ написал: Я б поменял  циклы местами
Я поменял циклы местами, как в вашем примере.. но у меня что то не сростается.. срабатывает инпатбокс а уже после нажатия ОК выбивает в ошибку.. что то я не так делаю, не могли бы чуть конкретнее дать пример как именно вы сделали замену в самом коде.. может я что то не правильно записал.

Цитата
Hugo написал: ...например там есть такое: букетбукетабукетахбукетикбукетовбукеты. Вот зачем искать 5 последующих, если уже искали первое?
Прошу прощения, просто накидал для примера не обработанный список, а так там всегда обычно по одному уникальному слову. Но в любом случае хоть там 10 уникальных ключей он в массиве первого столбца ищет веченость.
 
Ну, этот макрос в этих условиях вообще корректно работать не будет, ибо по поиску букет он найдет и букет, и букетик, которые искать нужно, и букетосик, который искать не нужно.
 
ну так и должно быть слова в примере не те, если нужно будет искать по точному совпадению то я уже смогу легко поменять.. Главный вопрос в том что он тупит неизмеримо
 
Не шибко выпендрежистый макрос на исходных данных работает 0,87с против 22с, выпендрежистый - 0,78с
При увеличении диапазона в столбце А до 55500 строк 40с и 36с соответственно.
Код
Sub Color_SubStr_ССМ_2()
    Dim sSubStr As String    'искомое слово или фраза
    Dim lCol As Long    'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim avArr, lr As Long
    Dim arr, lInStr&
    Dim t!
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub
    t = Timer
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    'заносим в массив значения листа, в котором необходимо удалить строки
    arr = Cells(1, lCol).Resize(lLastRow, 2).Value
    'Получаем с ССМ значения, которые надо удалить в активном листе
    With Sheets("ССМ")    'Имя листа с диапазоном значений на удаление
        avArr = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp))
    End With
    'удаляем
    For lr = 1 To UBound(avArr, 1)
        sSubStr = avArr(lr, 1)
        For li = 1 To lLastRow    'цикл с первой строки до конца
            lInStr = InStr(1, arr(li, 1), sSubStr, 1)
            If lInStr > 0 Then
                If lInStr = 1 Then
                    If Mid$(arr(li, 1), lInStr + Len(sSubStr), 1) = " " Then arr(li, 2) = "x"
                ElseIf lInStr - 1 + Len(sSubStr) = Len(arr(li, 1)) Then
                    If Mid$(arr(li, 1), lInStr - 1, 1) = " " Then arr(li, 2) = "x"
                Else
                    If Mid$(arr(li, 1), lInStr - 1, 1) = " " And Mid$(arr(li, 1), lInStr + Len(sSubStr), 1) = " " Then arr(li, 2) = "x"
                End If
            End If
        Next li
    Next lr
    Application.ScreenUpdating = 0
    For li = 1 To lLastRow    'цикл с первой строки до конца
        If Len(arr(li, 2)) Then Cells(li, 1).Interior.Color = 255
    Next
    Application.ScreenUpdating = 1
    Debug.Print Format(Timer - t, "0.0000")
End Sub
 
RAN, Полагаю, что к исправленному алгоритму прибавилось еще исключением из обработки UNION. Как я писал  тут результат уже подходит для работы, но ради интереса, а если массив слов второго массива в словарь, проверку разделить на слова и проверять по наличию в словаре? Хотя тогда точное совпадение получится.
Изменено: БМВ - 15.10.2018 07:47:23
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
но ради интереса, а если массив слов второго массива в словарь, проверку разделить на слова и проверять по наличию в словаре? Хотя тогда точное совпадение получится.
я о таком тоже думал, но реализовать чуть геморойнее будет по моему)

RAN, Ваш пример работает супер. Пока буду тестировать.

RAN, БМВ, Спасибо большое за помощь и активное участие, очень благодарен. Буду пока пробовать все это внедрять и разбираться с этим))
Страницы: 1
Наверх