Using VBA to remove row based on words listed in another sheet - slow performance

Question

I have a sheet (sheet1) with a large amount of data. This data has several columns, one of which is called nameColumn. nameColumn contains a single word per row.

In shee

Answer 1

Instead of deleting the rows of Sheet1 data with matching words, the code below creates a new copy of the data -- excluding the rows with matching words -- in Sheet3. The next steps would be to delete Sheet1 and rename and move Sheet3 (I have not included those steps in the code).

The code copies the nameColumn in Sheet1 and the wordColumn in Sheet2 into VBA arrays. It loops through the nameColumn array searching for matches in the wordColumn array. To speed up the matching process, the word list in Sheet2 is sorted prior to matching. When a match is found, a flag value of 1 is set in the result array.

It then writes the result array back to Sheet1 and sets an autofilter on the Sheet1 data range to exclude rows with matched words. The last step is copying the filtered data to Sheet3.

I tested the code on a 42,000-word nameColumn with 26 columns of random numeric data, matched against a sorted 600-word list randomly drawn from the nameColumn words. The code took about 5 seconds to run, with 80 percent of that time spent in the word match loop. (I also tested a version of the code that deleted the matched rows in place, a change which doubled the execution time.)

Sub FilterOnNoMatchAndCopy()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim ws1LastCell As Range, ws2LastCell As Range
    Dim valueArr(), searchArr(), resultArr()
    Dim i As Long, j As Long
    Dim sort_Sheet2_list As Boolean

    sort_Sheet2_list = True

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
    Set ws2 = ActiveWorkbook.Worksheets("Sheet2")

'   create Sheet3 if it doesn't exist, clear it if it does
    Set ws3 = Nothing
    On Error Resume Next
    Set ws3 = ActiveWorkbook.Worksheets("Sheet3")
    On Error GoTo 0
    If ws3 Is Nothing Then
        Worksheets.Add(After:=ws2).Name = "Sheet3"
        Set ws3 = ActiveWorkbook.Worksheets("Sheet3")
    End If
    ws3.Cells.Clear

'   Find last cell in used ranges
    With ws1
        Set ws1LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With
    With ws2
        Set ws2LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With

'   copy the nameColumn and wordColumn into VBA arrays 
'   (if nameColumn and wordColumn are not in column A, change here)     
    valueArr = ws1.Range("$A$2:$A$" & ws1LastCell.Row)
    If sort_Sheet2_list Then
        ws2.Range("$A$2:$A$" & ws2LastCell.Row).Sort Key1:=ws2.Range("A2"), _
            Order1:=xlAscending, Header:=xlNo
    End If
    searchArr = ws2.Range("$A$2:$A$" & ws2LastCell.Row)

'   create a new array that will flag which words in nameColumn are matches
    ReDim resultArr(LBound(valueArr, 1) To UBound(valueArr, 1), 1 To 1)

'  search for matches 
   For i = 1 To UBound(valueArr, 1)
        j = 1
        Do While j < (UBound(searchArr, 1) + 1)
            If valueArr(i, 1) > searchArr(j, 1) Then
                j = j + 1
            Else
                If valueArr(i, 1) = searchArr(j, 1) Then
                    resultArr(i, 1) = 1
                End If
                j = UBound(searchArr, 1) + 1
            End If
        Loop
    Next

'   write match results to Sheet1, set autofilter to exclude matches, 
'       and copy result to Sheet3
    With ws1
        .Cells(1, ws1LastCell.Column + 1).value = "found"
        .Range(.Cells(2, ws1LastCell.Column + 1), _
            .Cells(ws1LastCell.Row, ws1LastCell.Column + 1)) = _
            resultArr
        .Range("A1").AutoFilter ws1LastCell.Column + 1, "<>1"
        .Range(.Cells(1, 1), .Cells(ws1LastCell.Row, ws1LastCell.Column)).Copy Destination:=ws3.Range("A1")
        .AutoFilterMode = False
        .Cells(1, ws1LastCell.Column + 1).EntireColumn.Delete
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub