Macro to clear and delete filtered rows

[howard]

I have a macro below to delete filtered rows on sheet "Sales Report"


It takes a very long time to run

It would be appreciated if someone could kindly amend my code

 Sub DeleteFilteredData ()
Dim LR As Long

With Sheets("Sales Report")
LR = Cells(Rows.Count, "A").End(xlUp).Row


If LR > 1 Then
Range("A2:A" & LR).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With

End Sub

 

[howard]

I have amended my code to deleted the filtered data below the headings. Although much faster than the previous version it is but takes +- 5 mins to run

I would like the code amended so that it is faster to delete the filtered data below the headings

 Sub DeleteFilteredData()


Dim rngFilt As Range
Dim CellCount As Long
Dim Msg As String

'If the data has not been filtered with the AutoFilter, exit the sub
With Sheets("Sales Report")
If .AutoFilterMode = False Or .FilterMode = False Then
MsgBox "Please filter the data with the AutoFilter, and try again!"
Exit Sub
End If
End With

With Sheets("Sales Report").Autofilter.Range

'For Excel 2007 and earlier, check for the SpecialCells limitation
If Val(Application.Version) < 14 Then

On Error Resume Next
CellCount = .Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0

If CellCount = 0 Then
Msg = "The SpecialCells limit of 8,192 areas has been "
Msg = Msg & vbNewLine
Msg = Msg & "exceeded for the filtered value."
Msg = Msg & vbNewLine & vbNewLine
Msg = Msg & "Tip: Sort the data, and try again!"
MsgBox Msg, vbExclamation, "SpecialCells Limitation"
GoTo ExitTheSub
End If

End If

'Set the filtered range
On Error Resume Next
Set rngFilt = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

'Delete the filtered data
If Not rngFilt Is Nothing Then
rngFilt.EntireRow.Delete
Else
MsgBox "No records are available to delete...", vbExclamation
End If

End With

ExitTheSub:

    'Clear the filter
Sheets("Sales Report").ShowAllData

End Sub

It would be appreciated if someone could kindly amend my code to speed it up

 

[mumps]

I'm not sure if how much of a difference this will make, but give it a try.

Sub DeleteFilteredData()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Dim rngFilt As Range, CellCount As Long
    
    'If the data has not been filtered with the AutoFilter, exit the sub
    With Sheets("Sales Report")
        If .AutoFilterMode = False Or .FilterMode = False Then
            MsgBox "Please filter the data with the AutoFilter, and try again!"
            Exit Sub
        End If
    End With
        
    With Sheets("Sales Report").AutoFilter.Range
        'For Excel 2007 and earlier, check for the SpecialCells limitation
        If Val(Application.Version) < 14 Then
            On Error Resume Next
            CellCount = .Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0
            If CellCount = 0 Then
                MsgBox "The SpecialCells limit of 8,192 areas has been " & vbNewLine & "exceeded for the filtered value." _
                    & vbNewLine & vbNewLine & "Tip: Sort the data, and try again!", vbExclamation, "SpecialCells Limitation"
                GoTo ExitTheSub
            End If
        End If
        
        'Set the filtered range
        On Error Resume Next
        Set rngFilt = .Offset(1)
        On Error GoTo 0
        
        'Delete the filtered data
        If Not rngFilt Is Nothing Then
            rngFilt.EntireRow.Delete
        Else
            MsgBox "No records are available to delete...", vbExclamation
        End If
    End With
ExitTheSub:
        'Clear the filter
    Sheets("Sales Report").ShowAllData
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[howard]

Hi Mumps

Thanks for the help. Your code is +- 50 % faster

 

[mumps]

You are very welcome. I hope that's fast enough!!

 

[howard]

I'm happy with the speed

 

[mumps]

Glad it worked out.