Sub slows down when called multiple times - excel

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.