EXCELで絞り込んだ結果を行削除

数十万行あるCSVから指定項目の行を削除するVBAを作成
最初に行DELETEで検証　→　時間が鬼かかる

vba

Option Explicit

Sub exec()
    Dim workCol As Collection
    Set workCol = New Collection
    Dim filterItem As Variant
    
    '要素の追加(初期化)
    With workCol
        .Add "あああ"
        .Add "いいい"
        .Add "ううう"
        .Add "えええ"
        .Add "おおお"
    End With

    Application.ScreenUpdating = False

    For Each filterItem In workCol
        Call filter(filterItem)
    Next workItem
    
    Application.ScreenUpdating = True
    
End Sub

Private Sub filter(ByVal item As String)
    
    '項目でフィルタをかける
    Range("A1").AutoFilter 10, item
    
    'フィルタ結果がある場合実行
    If WorksheetFunction.Subtotal(3, Range("A:A")) > 1 Then
        
        '見出しを除くフィルタ結果を削除
        With Range("A1").CurrentRegion
            .Resize(.Rows.Count - 1).Offset(1, 0).EntireRow.Delete
        End With
            
    End If
    
    'フィルタを解除
    Range("A1").AutoFilter
    
End Sub

上記ソースでは時間が鬼かかるので違う方法を模索
①フィルタ
②行クリア
③フィルタ解除
④並び替え(空白行を下に)
⑤以後繰り返し
10数時間かかっていたのが3分で処理出来るようになった！

vba

Option Explicit

Sub exec()
    Dim workCol As Collection
    Set workCol = New Collection
    Dim filterItem As Variant
    
    '要素の追加(初期化)
    With workCol
        .Add "あああ"
        .Add "いいい"
        .Add "ううう"
        .Add "えええ"
        .Add "おおお"
    End With

    Application.ScreenUpdating = False

    For Each filterItem In workCol
        Call filter(filterItem)
    Next workItem
    
    Application.ScreenUpdating = True
    
End Sub

Private Sub filter(ByVal item As String)
    
    '項目でフィルタをかける
    Range("A1").AutoFilter 10, item
    
    'フィルタ結果がある場合実行
    If WorksheetFunction.Subtotal(3, Range("A:A")) > 1 Then
        
        '見出しを除くフィルタ結果をクリア
        With Range("A1").CurrentRegion
            .Resize(.Rows.Count - 1).Offset(1, 0).Clear
        End With
            
    End If
    
    'フィルタを解除
    Range("A1").AutoFilter
    
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("B1"), Order:=xlAscending
        .SetRange Range("A1:AV1048576")
        .Header = xlYes
        .Apply
    End With
End Sub