Sub тормозит при многократном вызове

Question

Я пытаюсь отфильтровать данные на 3 разных листах, используя этот код, но подпункт filterBy работает значительно медленнее на втором и третьем листах, когда я использую expressPrepper, чтобы сделать все это одним щелчком мыши.

Я предполагаю, что второй и третий filter by работают примерно на 1/200 скорости первого.Я не могу понять, почему.

Все три листа содержат аналогичные данные, хотя третий фактически короче (~ 6500 строк), чем первые два (~ 16000 строк каждый).

Любойпомощь будет принята с благодарностью!

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

Если я правильно понимаю вашу программу, не должно быть необходимости в фильтрации и, следовательно, нет проблем с применением тысяч фильтров.Я переписал вашу программу - так, как я ее понял - без такой необходимости, по сути, удаляя строки, которые не имеют дубликатов в указанном столбце.Код не проверен.

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

Обратите внимание, что прогресс отображается в строке состояния в левой нижней части экрана.