Como fazer o loop aninhado mais rápido para encontrar o instr na vba

Question

Descrição do problema: Percorra as linhas máximas do Excel (aprox. 10000000) para localizar o instr. Depois de encontrar instr, pegue os valores e copie os valores para uma folha diferente. Sempre que encontrar a correspondência que é instr, copie o valor apenas das correspondências e cole-o na folha diferente.

Problema: estou usando o loop aninhado e o meu loop está lento, então, para 10 milhões de linhas, ele leva cerca de 19:37 minutos. Eu cronometrei isto. Então, a primeira questão é que existem maneiras diferentes de fazê-lo ou como torná-lo mais rápido em vez de 20 minutos, é possível comparar 20 milhões (cada folha 10 milhões de linhas, 10 milhões de seqüências de caracteres) seqüências dentro de 1 min ou dois. Aqui está o meu código atual

  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

Ler e gravar em células em uma planilha desacelera qualquer macro. O código a seguir copia valores de célula em matrizes e faz um loop por meio deles. A saída é copiada em partes de uma matriz de resultados para a planilha de destino. No meu bloco de notas, o código original levou 56 segundos, este código 3,7 segundos:

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

    

Answer 2

Embora eu já tenha oferecido uma resposta, quero propor aqui um algoritmo totalmente diferente para melhorar o desempenho em outra ordem de magnitude.
Quando a "lista grande" na planilha1 é verificada e as correspondências na planilha2 são pesquisadas, as informações sobre uma pesquisa bem-sucedida são descartadas após uma passagem. Sheet1 conterá repetições de um valor de pesquisa e, ao digitalizar sheet2, podemos usar sua frequência.

Os meios para encontrar valores de pesquisa exclusivos e suas frequências é um objeto de dicionário. Para usá-lo no VBA, é necessário adicionar uma referência ao "Microsoft Scripting" no editor do VBA.
A segunda suposição é que a lista de saída não precisa preservar a ordem de entrada (porque ela será ordenada de qualquer maneira). O código a seguir produzirá uma lista de saída em sheet3 com valores de pesquisa na ordem em que eles ocorrem na lista grande, mas com todas as repetições em um bloco. As declarações de tempo foram comentadas, pois é necessária uma definição de classe externa para isso.

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

Comparado ao código do OP, a melhoria da velocidade é de 1: 186. Uma corrida de 20 minutos levaria apenas alguns segundos.

    

Answer 3

Eu usaria o suplemento de consulta de energia para isso. Ele tem uma função Text.Contains que é aproximadamente semelhante ao InStr do VB. Eu tive esse desafio em particular e consegui trabalhar. Você pode baixar e usar meu arquivo de demonstração do meu OneDrive:

link

É o arquivo: Demonstração do Power Query - Procurando por uma lista de strings entre outra lista de strings.xlsx.

Como descrito na folha Leia-me, não precisei escrever muitas funções - ela foi criada principalmente ao clicar na interface do usuário.

Meu design é cruzar as tabelas de Busca e Destino (eu acho que o equivalente a sua Folha1 e Folha2) para obter todas as combinações possíveis, depois aplicar a função Text.Contains e filtrar o resultado.

Um objetivo principal do projeto é a velocidade - ele é executado em cerca de 1 segundo para os dados de teste semi-aleatórios atuais: 19 Search Strings (atualmente palavras isoladas) 78780 strings alvo (atualmente linhas de guerra e paz) (então cerca de 1,5 milhões de combinações) 9268 correspondências de saída.

Escala não trivial, mas nem de longe os seus requisitos. Espero que isso atenda às suas necessidades - estou ansioso para saber como é isso.

Observe que a consulta Target_Strings pode ser substituída por um dado de consulta diretamente de um banco de dados ou site - o Power Query não se limita ao Excel como fonte de dados.