How to use VBA to quickly and easily delete unfiltered rows

Recently I ran into a situation where an Excel file was so large it would not copy only filtered rows to a second sheet. Attempting to do so caused Out of Memory errors. I needed to come up with something that was fast, so processing row by row was not an option. Below is the code that I came up with. It deleted 20,000+ rows in just a couple of seconds. The secret was to keep track of contiguous hidden rows and delete them as a block instead of one at a time.

By processing from the last row to the top, I could still iterate the rows without impacting anything as I deleted unfiltered rows. Here is Immediate Window output for reference purposes.

• 1 Rows( 22798 : 29617 )
• 2 Rows( 22784 : 22796 )
• 3 Rows( 22765 : 22782 )
• 4 Rows( 22749 : 22763 )
• 5 Rows( 22733 : 22747 )
• 6 Rows( 22717 : 22731 )
• 7 Rows( 22701 : 22715 )
• 8 Rows( 22685 : 22699 )
• 9 Rows( 22671 : 22683 )
• 10 Rows( 22660 : 22669 )
• .
• .
• .
• 99 Rows( 3486 : 3511 )
• 100 Rows( 2931 : 3484 )
• 101 Rows( 2886 : 2929 )
• 102 Rows( 2816 : 2884 )
• 103 Rows( 1282 : 2814 )
• 104 Rows( 1257 : 1280 )
• 105 Rows( 901 : 1255 )
• 106 Rows( 886 : 899 )
• 107 Rows( 773 : 884 )
• 108 Rows( 727 : 771 )
• 109 Rows( 358 : 725 )
• 110 Rows( 4 : 356 )

Please, test the next way. It will check the rows visibility of A:A range and create a Union range containing the hidden cells. Then, delete the range EntireRow at the end:

Sub removeHFrows()
  Dim sh As Worksheet, lastR As Long, lHeaderRow As Long, rngA As Range, rngH As Range, i As Long
  
  Set sh = ActiveSheet ' Use here the sheet you need
  lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row    'supposing that A:A is not shorter then other columns...
  lHeaderRow = 3
  Set rngA = sh.Range("A1:A" & lastR)
  
  For i = 3 To lastR
        If rngA.Rows(i).Hidden Then
            If rngH Is Nothing Then
                Set rngH = rngA(i)              'firstly set the range
            Else
                Set rngH = Union(rngH, rngA(i)) 'make a Union between the previous cells in the range and this one
            End If
        End If
  Next i
  'delete the Union range rows, at once:
  If Not rngH Is Nothing Then rngH.EntireRow.Delete
End Sub

Alternatively count the number of hidden rows in each block and use Resize().

Private Sub RemoveHiddenRows(Sh As Worksheet, lHeaderRow As Long)

    Dim startrow As Long, endrow As Long
    Dim n As Long, i As Long, t As Long
    Dim t0 As Single: t0 = Timer
     
    n = 0
    With Sh
        If .AutoFilterMode = False Then Exit Sub
        startrow = .AutoFilter.Range.Row
        endrow = .AutoFilter.Range.Rows.Count + startrow - 1
        For i = endrow To startrow Step -1
            If .Rows(i).Hidden Then
                n = n + 1 ' count hidden rows
            ElseIf n > 0 Then
                .Rows(i + 1).Resize(n).Delete Shift:=xlUp
                t = t + n
                n = 0
            End If
        Next
        .AutoFilter.ShowAllData
    End With
    
    MsgBox t & " rows deleted", vbInformation, _
           Format(Timer - t0, "0.0 secs")
End Sub