Sub slows down when called multiple times

Question

I am trying to filter data on 3 different sheets using this code, but the filterBy sub runs dramatically slower on the second and third sheet when I use expressPrepper to do it all in one click.

I'm guessing the second and third filter by run approximately 1/200 the speed of the first one. I can't figure out why.

All three sheets contain similar data, although the third is actually shorter (~6500 rows) than the first two (~16000 rows each).

Any help would be greatly appreciated!

Sub filterBy(filterlist As String, col As String, sht As String)
    Dim myArr As Variant
    myArr = buildArray(filterlist)
    clean myArr, col, sht

End Sub


Function buildArray(filterlist As String) As Variant

Dim myTable As ListObject
Dim TempArray As Variant

    Select Case filterlist

    Case Is = "I"
        Set myTable = Sheets("Competitive Set").ListObjects("Table1")
        TempArray = myTable.DataBodyRange.Columns(1)
        buildArray = Application.Transpose(TempArray)
    Case Is = "T"
        Set myTable = Sheets("Competitive Set").ListObjects("Table1")
        TempArray = myTable.DataBodyRange.Columns(2)
        buildArray = Application.Transpose(TempArray)
    Case Is = "IB"
        Set myTable = Sheets("Competitive Set").ListObjects("Table2")
        TempArray = myTable.DataBodyRange.Columns(1)
        buildArray = Application.Transpose(TempArray)
    Case Is = "TB"
        Set myTable = Sheets("Competitive Set").ListObjects("Table2")
        TempArray = myTable.DataBodyRange.Columns(2)
        buildArray = Application.Transpose(TempArray)
    Case Is = "AB"
        Set myTable = Sheets("Competitive Set").ListObjects("Table3")
        TempArray = myTable.DataBodyRange.Columns(1)
        buildArray = Application.Transpose(TempArray)
    End Select

End Function

Sub clean(arr As Variant, col As String, sht As String)

Dim IsInArray As Long
Dim product As String
Dim lastRow As Long, i As Long
Dim progress As Double


With Sheets(sht)
    lastRow = .Cells(Rows.Count, col).End(xlUp).Row
    For i = lastRow To 2 Step -1
          product = .Cells(i, col).Value
          IsInArray = UBound(filter(arr, product))
          If IsInArray < 0 Then
             .Rows(i).EntireRow.Delete
          End If

    progress = ((lastRow - i) / lastRow) * 100
    progress = Round(progress, 2)
    Debug.Print progress

    Next i

End With

End Sub

Sub expressPrepper()

filterBy "AB", "C", "Spend"
filterBy "AB", "C", "IMP"
filterBy "AB", "C", "GRP"

End Sub

Answer 1

If I understand your program correctly there should be no need for filtering and, hence, no problem from applying thousands of filters. I have re-written your program - the way I understood it - without such need, basically, deleting rows which don't have a duplicate in the designated column. The code is untested.

Sub ExpressFilter()

    Dim Flt() As String, i As Integer
    Dim Sp() As String, j As Integer
    Dim TblName As String
    Dim ClmRng As Range

    Flt = Split("AB,C,Spend|AB,C,IMP|AB,C,GRP", "|")
    For i = 0 To UBound(Flt)
        Sp = Split(Flt(i), ",")
        Select Case Sp(0)
            Case Is = "I"
                TblName = "Table1"
                C = 1
            Case Is = "T"
                TblName = "Table1"
                C = 2
            Case Is = "IB"
                TblName = "Table2"
                C = 1
            Case Is = "TB"
                TblName = "Table2"
                C = 2
            Case Is = "AB"
                TblName = "Table3"
                C = 1
        End Select
        Set ClmRng = Worksheets("Competitive Set").ListObjects(TblName).DataBodyRange.Columns(C)

        DeleteSingles ClmRng, Columns(Sp(1)).Column, Sp(2)
    Next i
End Sub

Private Sub DeleteSingles(ClmRng As Range, _
                          C As Long, _
                          Sht As String)

    Dim Fnd As Range
    Dim IsInArray As Long
    Dim lastRow As Long, R As Long

    With Sheets(Sht)
        lastRow = .Cells(Rows.Count, C).End(xlUp).Row
        For R = lastRow To 2 Step -1
            With ClmRng
                Set Fnd = .Find(What:=.Cells(R, C).Value, _
                           After:=.Cells(.Cells.Count), _
                           LookIn:=xlValues, _
                           LookAt:=xlWhole, _
                           MatchCase:=False)
            End With
            If Fnd Is Nothing Then .Rows(R).EntireRow.Delete

            If (R Mod 25 = 0) or (R = 2) Then
                Application.StatusBar = Round(((lastRow - R) / lastRow) * 100, 0) & "% done"
            End If
        Next R
    End With
End Sub

Note that the progress is shown in the Status Bar at the left bottom of the screen.