Delete all rows in filtered range Except first filtered row in excel VBA

I want to delete all rows in filtered range except the first visible row after header.

For example,

This is a sample table:

I want to delete all the filtered rows of apple Except row number 3 which is the first visible filtered row.

I have tried below code :

Sub Filter()
    Dim cl, rng As Range

    Range("A1").AutoFilter Field:=1, Criteria1:="Apple"
    Set rng = Range("A2:A7")
    For Each cl In rng.SpecialCells(xlCellTypeVisible)
        cl.EntireRow.Delete     
    Next cl
End Sub

The problem with this code is that it deletes all the filtered rows. How to specify not to delete first visible row

Use a flag to omit first row

Sub Filter()
    Dim cl as Range, rng As Range ' type all variables, otherwise they'll be Variants
    Dim FirstRow as Boolean

    FirstRow  = True
    Range("A1").AutoFilter Field:=1, Criteria1:="Apple"
    Set rng = Range("A2:A7")
    For Each cl In rng.SpecialCells(xlCellTypeVisible)
        If Not FirstRow Then
            cl.EntireRow.Delete
        End If
        FirstRow = False
    Next cl
End Sub

No need for a loop.

Here is an example

Option Explicit

Sub Filter()
    Dim ws As Worksheet
    Dim rng As Range
    Dim rngFiltered As Range
    
    '~~> Change this to the relevant worksheet
    Set ws = Sheet1
    
    With ws
        '~~> Remove existing filter
        .AutoFilterMode = False
        
        Set rng = ws.Range("A1:A7")
    
        With rng
            .AutoFilter Field:=1, Criteria1:="Grapes"
            
            '~~> Check if the 2nd row is hidden
            If ws.Rows(.Offset(1, 0).Row).EntireRow.Hidden = True Then
                If .SpecialCells(xlCellTypeVisible).Areas.Count > 1 Then _
                .Offset(.SpecialCells(xlCellTypeVisible).Areas(2).Row + 1, 0).EntireRow.Delete
            Else
                .Offset(2, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            End If
        End With
        
        '.AutoFilterMode = False
    End With
End Sub

Delete Filtered Rows But Skip First

<!-- language: lang-vb -->

Sub DeleteFilteredSkipFirst()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' has headers
    Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1) ' no hdrs.
    
    rg.AutoFilter Field:=1, Criteria1:="Apple"
    
    Dim vrg As Range
    On Error Resume Next
        Set vrg = drg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ws.AutoFilterMode = False
    
    If vrg Is Nothing Then Exit Sub
    
    Dim urg As Range, rrg As Range, IsFirstFound As Boolean
    
    For Each rrg In vrg.Rows
        If IsFirstFound Then
            If urg Is Nothing Then
                Set urg = rrg
            Else
                Set urg = Union(urg, rrg)
            End If
        Else
            IsFirstFound = True
        End If
    Next rrg
                
    If urg Is Nothing Then Exit Sub
    
    urg.Delete xlShiftUp
    
    MsgBox "Rows deleted.", vbInformation
    
End Sub