Compare duas colunas para correspondências usando vba

Question

Eu realmente apreciaria se alguém tivesse uma idéia de como executar a tarefa a seguir com mais rapidez. Tenho uma lista de nomes na coluna A e quero ver se algum desses nomes aparece na coluna C. O código abaixo funcionou muito bem quando o testei com 500 nomes. Mas quando uso meus dados completos que têm cerca de 3.000 valores na coluna A e 150.000 na coluna C, não tenho certeza se estão funcionando corretamente porque já se passaram quase duas horas e ainda não foram concluídos.

Sub compare_cols122()

    Dim NameList As Worksheet
    Dim i As Long, j As Long
    Dim LastRow As Long

    Set NameList = Excel.Worksheets("Names")


    LastRow = NameList.UsedRange.Rows.Count

    Application.ScreenUpdating = False

    For i = 2 To LastRow
        For j = 2 To LastRow
            If NameList.Cells(i, 1).Value <> "" Then
                If InStr(1, NameList.Cells(j, 3).Value, NameList.Cells(i, 1).Value, vbTextCompare) > 0 Then
                    NameList.Cells(j, 3).Interior.ColorIndex = 6
                    NameList.Cells(i, 1).Interior.ColorIndex = 6
                    Exit For
                Else
                End If
            End If
        Next j
    Next i

Application.ScreenUpdating = True

End Sub

Answer 1

Aqui está o seu código acelerado carregando os dados em arrays e realizando a comparação com eles:

Sub compare_cols122()

    Dim NameList As Worksheet
    Dim i As Long, j As Long

    Set NameList = Excel.Worksheets("Names")

    Dim rngNames As Range
    Set rngNames = Range("A1", Range("A1").Offset(Rows.Count - 1).End(xlUp))
    Dim varNames As Variant
    varNames = rngNames.Value2

    Dim rngData As Range
    Set rngData = Range("C1", Range("C1").Offset(Rows.Count - 1).End(xlUp))
    Dim varData As Variant
    varData = rngData.Value2

    Application.ScreenUpdating = False

    For i = LBound(varNames) + 1 To UBound(varNames)
        For j = LBound(varData) + 1 To UBound(varData)
            If varNames(i, 1) <> "" Then
                If InStr(1, varData(j, 1), varNames(i, 1), vbTextCompare) > 0 Then
                    NameList.Cells(j, 3).Interior.ColorIndex = 6
                    NameList.Cells(i, 1).Interior.ColorIndex = 6
                    Exit For
                Else
                End If
            End If
        Next j
    Next i

    Application.ScreenUpdating = True

End Sub

Observe que trocar os loops interno e externo apenas tornará a pesquisa mais lenta, independentemente de quão raras sejam as correspondências.

Answer 2

Ler os dados das células repetidamente é ineficiente.

Use uma(s) matriz(es) para carregar todos os valores.

Em seguida, faça o que você precisa fazer com o array.

Coloque os valores de volta nas células quando tudo estiver pronto.