Speed Up Filter and Delete

[nniedzielski]

I am running this macro on a Worksheet called Data, I am doing 3 separate filter and deletes, and i was looking for a solution to combine them into one action, with hopes that it speeds up the macro run time, its currently around 21 seconds, and i think this section is responsible for a good chunk of that.

Note: I have ScreenUpdating off, DisplayEvents off and EnableEvents off

' Filter column AH for Yes
    ws.Range("AH1").AutoFilter Field:=34, Criteria1:="1"
    
    ' Delete all visible rows except header row
    lastRow = ws.Cells(ws.Rows.Count, "AH").End(xlUp).Row
    
    Set visibleRows = ws.Range("AH2:AH" & lastRow).SpecialCells(xlCellTypeVisible)
    If Not visibleRows Is Nothing Then visibleRows.EntireRow.Delete
    
    ' Remove filter
    ws.AutoFilterMode = False
    
    'delete non US
    ws.Range("S1").AutoFilter Field:=19, Criteria1:="<>US"
    
    ' Delete all visible rows except header row
    lastRow = ws.Cells(ws.Rows.Count, "S").End(xlUp).Row
    
    Set visibleRows = ws.Range("S2:S" & lastRow).SpecialCells(xlCellTypeVisible)
    If Not visibleRows Is Nothing Then visibleRows.EntireRow.Delete
    
    ' Remove filter
    ws.AutoFilterMode = False
    
    ws.Range("Y1").AutoFilter Field:=25, Criteria1:="<>US"
    
    ' Delete all visible rows except header row
    lastRow = ws.Cells(ws.Rows.Count, "y").End(xlUp).Row
    
    Set visibleRows = ws.Range("Y2:Y" & lastRow).SpecialCells(xlCellTypeVisible)
    If Not visibleRows Is Nothing Then visibleRows.EntireRow.Delete
    
    ' Remove filter
    ws.AutoFilterMode = False

 

[mumps]

Try:

Sub DeleteRows()
    Application.ScreenUpdating = False
    With ws
        .Range("AH1").AutoFilter Field:=34, Criteria1:="1"
        If .[subtotal(103,A:A)] - 1 > 0 Then
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
        End If
        .Range("S1").AutoFilter Field:=19, Criteria1:="<>US"
        If .[subtotal(103,A:A)] - 1 > 0 Then
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
        End If
        .Range("Y1").AutoFilter Field:=25, Criteria1:="<>US"
        If .[subtotal(103,A:A)] - 1 > 0 Then
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
        End If
    End With
    Application.ScreenUpdating = True
End Sub

You would, of course, have to define the value of ws before running the macro.

 

[nniedzielski]

Try:

Sub DeleteRows()
    Application.ScreenUpdating = False
    With ws
        .Range("AH1").AutoFilter Field:=34, Criteria1:="1"
        If .[subtotal(103,A:A)] - 1 > 0 Then
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
        End If
        .Range("S1").AutoFilter Field:=19, Criteria1:="<>US"
        If .[subtotal(103,A:A)] - 1 > 0 Then
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
        End If
        .Range("Y1").AutoFilter Field:=25, Criteria1:="<>US"
        If .[subtotal(103,A:A)] - 1 > 0 Then
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
        End If
    End With
    Application.ScreenUpdating = True
End Sub

You would, of course, have to define the value of ws before running the macro.

this worked, but took the same amount of time

 

[Peter_SSs]

Exactly the same concept as I gave you here (which you haven't responded to yet )

Sub Del_Multiple_Conditions()
  Dim ws As Worksheet
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long, lr As Long
 
  Set ws = Sheets("Data")
  With ws
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    lr = .Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lr & ")"), Array(19, 25, 34)) '<- last array is cols S, Y and AH
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 1) <> "US" Or a(i, 2) <> "US" Or a(i, 3) = "1" Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      Application.Calculation = xlCalculationManual
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True
    End If
  End With
End Sub