Как сделать вложенный цикл быстрее, чтобы найти instr в vba

Question

Описание проблемы: Прокрутите ряды Excel Max (около 10000000), чтобы найти инстр. После нахождения instr, возьмите значения и скопируйте значения на другой лист. Каждый раз, когда вы найдете совпадение, которое является instr, скопируйте значение только совпадения и вставьте его на другой лист.

Проблема: я использую вложенный цикл, и мой цикл работает медленно, поэтому для 10 миллионов строк это занимает около 19:37 минут. Я рассчитал это. Итак, первый вопрос: есть ли другие способы сделать это или как сделать это быстрее, чем 20 минут, можно ли сравнить 20 миллионов (каждый лист 10 миллионов строк, 10 миллионов строк) строк в течение 1 минуты или двух. Вот мой текущий код

  Sub zym()
   Dim x As Long, lastrow As Long, lastrowx As Long, i As Long, ii As Long
   Dim ws As Worksheet, ws2 As Worksheet, b As String
   Dim j As Long

   Set ws = Worksheets("Sheet1")
   Set ws2 = Worksheets("Sheet2")
   Set ws3 = Worksheets("Sheet3")
   j = 1
      T1 = GetTickCount

  lastrow = ws.UsedRange.Rows.Count + 1
  lastrowx = ws2.UsedRange.Rows.Count + 1

   ReDim sheet1array(1 To lastrow)
   ReDim sheet2array(1 To lastrowx)

    For i = LBound(sheet1array) To UBound(sheet1array)
        b = "-" & ws.Range("A" & i) & "-"
      For ii = LBound(sheet2array) To UBound(sheet2array)
        If InStr(1, ws2.Range("A" & ii), b) > 0 Then
        ws3.Range("A" & j) = ws2.Range("A" & ii)
        j = j + 1
        End If

       Next ii
     Next i
    Debug.Print "Array Time = " & (GetTickCount - T1) / 1000#
    Debug.Print "Array Count = " & Format(ii, "#,###")

End Sub

Answer 1

Хотя я уже предложил ответ, я хочу предложить совершенно другой алгоритм, чтобы повысить производительность на другой порядок.
Когда сканируется "большой список" на листе 1 и выполняется поиск совпадений на листе 2, информация об успешном поиске выбрасывается после одного прохода. Sheet1 будет содержать повторы поискового значения, и при сканировании sheet2 мы можем использовать его частоту.

Средство поиска уникальных поисковых значений и их частот - объект словаря. Чтобы использовать его в VBA, необходимо добавить ссылку на "Microsoft Scripting" в редакторе VBA.
Второе предположение состоит в том, что список вывода не должен сохранять порядок ввода (потому что он все равно будет отсортирован). Следующий код создаст выходной список на листе 3 с поисковыми значениями в порядке их появления в большом списке, но со всеми повторениями в одном блоке. Заявления о времени были закомментированы, поскольку для этого необходимо определение внешнего класса.

Sub zym_dict()
' http://superuser.com/questions/976906/how-to-make-nested-loop-faster-to-find-instr-in-vba
' by E/S/P 2015-09-25
' 2nd improvement: use a dictionary object to count unique search items and loop over these
' speed 1:13 vs. array version; 1:186 vs. original (cell) version

    Dim numvalues As Long, i As Long, j As Long, nextresult As Long
    Dim numcompared As Long, numresults As Long
    Dim cnt As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim searchterm As String
    Dim values, arr2, results, c, v
    Dim uniq As New Scripting.Dictionary

    ' Dim mStopWatch As New clsStopWatch

    Set ws1 = Worksheets("sheet1")
    Set ws2 = Worksheets("sheet2")
    Set ws3 = Worksheets("sheet3")

    ' mStopWatch.StartWatch

    values = Intersect(ws1.Columns(1), ws1.UsedRange)
    arr2 = Intersect(ws2.Range("A:B"), ws2.UsedRange)
    numcompared = UBound(arr2, 1)

    ' collect unique values and their frequencies
    For i = 1 To UBound(values, 1)
        uniq(values(i, 1)) = uniq(values(i, 1)) + 1
    Next i

    numresults = 0
    ' 2nd index is repeat count
    For j = 1 To numcompared
        arr2(j, 2) = 0
    Next j

    For Each v In uniq
        searchterm = "-" & v & "-"
        cnt = uniq.Item(v)
        For j = 1 To numcompared
            If InStr(1, arr2(j, 1), searchterm) > 0 Then
                ' copy this value multiple times into result array
                arr2(j, 2) = arr2(j, 2) + cnt ' repeat count
                numresults = numresults + cnt
            End If
        Next j
    Next

    ' generate output list
    ReDim results(1 To numresults, 1 To 2)
    ws3.Columns(1).Clear
    nextresult = 0
    For i = 1 To numcompared
        v = arr2(i, 1)
        cnt = arr2(i, 2)  ' may be 0!
        For j = 1 To cnt
            results(nextresult + j, 1) = v
        Next j
        nextresult = nextresult + cnt
    Next i

    ' copy values to sheet
    ws3.Range(Cells(1, 1), Cells(nextresult, 2)) = results

    ' Debug.Print "runtime = " & Format(mStopWatch.StopWatch, "#0.00 ms")
    Debug.Print Format(nextresult, "#,### resulting lines")
End Sub

По сравнению с кодом ОП улучшение скорости составляет 1:186. Тогда 20-минутный забег займет всего пару секунд.

Answer 2

Я бы использовал Power Query Add-In для этого. У него есть текст.Содержит функцию, которая примерно похожа на InStr VB. Я попробовал этот конкретный вызов и заставил его работать. Вы можете скачать и использовать мой демонстрационный файл с моего OneDrive:

http://1drv.ms/1AzPAZp

Это файл: Power Query demo - поиск списка строк среди другого списка strings.xlsx.

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

Мой замысел заключается в перекрестном соединении таблиц «Поиск» и «Цель» (я думаю, что это эквивалент ваших Sheet1 и Sheet2), чтобы получить все возможные комбинации, а затем применить текст.Содержит функцию и фильтр по результату.

Ключевой целью разработки является скорость - она выполняется примерно за 1 секунду для текущих полуслучайных тестовых данных:19 строк поиска (в настоящее время отдельные слова)78780 строк-целей (в настоящее время строки из «Войны и мира»)(около 1,5 миллионов комбинаций)9268 Вывод Матчи.

Так что нетривиальные масштабы, но далеко не ваши требования. Надеюсь, это будет соответствовать вашим потребностям - я хочу услышать, как это происходит.

Обратите внимание, что запрос Target_Strings можно заменить одним запросом данных непосредственно из базы данных или веб-сайта - Power Query не ограничивается Excel в качестве источника данных.

Answer 3

Чтение и запись в ячейки на листе замедляет любой макрос. Следующий код копирует значения ячеек в массивы и проходит через них. Выходные данные копируются частями из массива результатов в целевой лист.
На моем ноутбуке оригинальный код занял 56 секунд, этот код 3,7 секунды:

Sub zym2()
    Dim lastrow As Long, i As Long, j As Long, start As Long
    Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim b As String
    Dim T1 As Long
    Dim arr1, arr2, arr3, c

    Set ws = Worksheets("sh1")
    Set ws2 = Worksheets("sh2")
    Set ws3 = Worksheets("sh3")
    ws3.Columns(1).Clear
    T1 = Timer

    arr1 = Intersect(ws.Columns(1), ws.UsedRange)
    lastrow = UBound(arr1)
    arr2 = ws2.UsedRange
    ReDim arr3(1 To lastrow / 10, 2)   ' initial length is arbitrary

    j = 0
    start = 1
    For i = 1 To lastrow
        b = "-" & arr1(i, 1) & "-"
        For Each c In arr2
            If InStr(1, c, b) > 0 Then
                If j = UBound(arr3) Then
                    ws3.Range(Cells(start, 1), Cells(start - 1 + j, 1)) = arr3
                    start = start + j
                    j = 0
                End If
                j = j + 1
                arr3(j, 1) = c
            End If
        Next c
    Next i
    If j > 0 Then
        ws3.Range(Cells(start, 1), Cells(start - 1 + j, 1)) = arr3
    End If
    Debug.Print "Array Time = " & Format(Timer - T1, "##.0")
    Debug.Print "Array Count = " & Format(start - 1 + j, "#,###")
End Sub