Macro to clear and delete filtered rows

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,784
Office Version
  1. 2019
Platform
  1. Windows
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


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
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,784
Office Version
  1. 2019
Platform
  1. Windows
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

Code:
 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

Well-known Member
Joined
Apr 11, 2012
Messages
10,311
I'm not sure if how much of a difference this will make, but give it a try.
VBA Code:
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

Well-known Member
Joined
Jun 26, 2006
Messages
5,784
Office Version
  1. 2019
Platform
  1. Windows
Hi Mumps

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

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,311

ADVERTISEMENT

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

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,784
Office Version
  1. 2019
Platform
  1. Windows
I'm happy with the speed
 

Watch MrExcel Video

Forum statistics

Threads
1,130,217
Messages
5,640,936
Members
417,180
Latest member
nomans2325

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top