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

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

CodePudding user response：

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

CodePudding user response：

No need for a loop. You can use the below to skip the first row.

.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete

Here is an example

Option Explicit

Sub Filter()
    Dim ws As Worksheet
    Dim rng As Range

    '~~> Change this to the relevant worksheet
    Set ws = Sheet1
    
    With ws
        '~~> Remove existing filter
        .AutoFilterMode = False
        
        '~~> If A1 has headers then change the below to A1:A7
        Set rng = ws.Range("A2:A7") 
    
        With rng
            .AutoFilter Field:=1, Criteria1:="Apple"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        
        .AutoFilterMode = False
    End With
End Sub

CodePudding user response：

Delete Filtered Rows But Skip First

Sub DeleteFilteredSkipFirst()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    If ws.FilterMode Then ws.ShowAllData
    
    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