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

Answer 2

See the comments in the following code. It creates a temporary array-formula in a column to the right of Sheet1. It's 20 columns to the right of the column we are checking - increase this number if necessary.

Sub DeleteAcross2()
    Dim calc As Variant
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim dels As Variant
    Dim x As Long
    Dim rngDel As Range

    Application.ScreenUpdating = False
    'remember the Calculation Mode to reinstate later
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual

    Set ws1 = Worksheets("Sheet1")
    Set rng1 = ws1.Range("B2:B70")      'change this range
    Set ws2 = Worksheets("Sheet2")
    Set rng2 = ws2.Range("A1:A4")       'change this range

    'add a formula-column 20 columns to the right - increase this number if necessary
    rng1.Offset(0, 20).FormulaArray = "=ISNA(MATCH(Sheet1!$B$2:$B$70,Sheet2!$A$1:$A$4,0))"
    'creates a column of True/False values - we will delete rows with False
    dels = rng1.Offset(0, 20).Value
    For x = 1 To UBound(dels, 1)
        If dels(x, 1) = False Then
            If rngDel Is Nothing Then
                Set rngDel = rng1.Cells(x, 1)       'the first cell
            Else
                Set rngDel = Union(rngDel, rng1.Cells(x, 1))
            End If
        End If
    Next x
    rng1.Offset(0, 20).Clear        'remove the array-formula (required)
    If rngDel Is Nothing Then Exit Sub      'no matches found
    rngDel.EntireRow.Delete
    Application.Calculation = calc
    Application.ScreenUpdating = True
End Sub

It won't take 20 minutes to run :)