Speed up Autofilter deleting rows

[LS]

Hi - I have another question which I hope someone can assist with.

I have a macro which will search a separate worksheet for values in
one column, then use autofilter to select all identical values in
the same column in the current worksheet and delete them. The
worksheets are both sorted so that Columns A & B are in
alphabetical order, to speed processing.

It works - but I am trying to speed it up. With 20,000 rows on the
worksheet, on my PC it is taking over 30 seconds to delete the rows.
At work it will take at least twice as long. Not disastrous, but if
I can speed it up, so much the better. The delay seems to be in the
deletion of the rows - the tests I have made show the 'For each '
loop will test the values in less than a second, its only when
it has to manipulate the sheet that it slows down.

Here's an extract of my code:
(NB Range 'ImportDataFilter' is a named range on the worksheet including
all data and a header row)

LastRow = Workbooks("New").Sheets("Sheet1").Cells
(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Workbooks("New").Worksheets("Sheet1").Range
("B8:B" & LastRow)

RegionToAdd = Workbooks("New").Sheets("Sheet1").Range("A8").Value
LocationToAdd = Workbooks("New").Sheets("Sheet1").Range("B8").Text

Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Sheet1").Activate
ActiveSheet.Unprotect PASSWORD:=PASSWORD
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
MyCount = 8 'data starts at row 8

For Each C In MyRange
D = C.Value

If LocationToAdd <> D Then ' ie this is a new location so
D is 1 more than last correct cell

ThisWorkbook.Worksheets("Sheet1").Activate
ThisWorkbook.Worksheets("Sheet1").Range("ImportDataFilter").Select
Selection.AutoFilter Field:=1, Criteria1:=RegionToAdd
Selection.AutoFilter Field:=2, Criteria1:=LocationToAdd
ThisWorkbook.Worksheets("Sheet1").Range("DATA").SpecialCells
(xlCellTypeVisible).Delete Shift:=xlUp

LocationToAdd = Workbooks("New").Worksheets("Sheet1").Range
("B" & MyCount).Value
RegionToAdd = Workbooks("New").Worksheets("Sheet1").Range
("A" & MyCount).Value
End If
MyCount = MyCount + 1
Next C

code continues ...

I have tried deleting the entire row instead of the cells, but get
an error message.

Any suggestions to speed this up gratefully received!

LS

 

[Ron de Bruin]

Hi LS

Try this basic example to delete rows/cells
http://www.rondebruin.nl/delete.htm#AutoFilter

 

[LS]

Hi LS

Try this basic example to delete rows/cells
http://www.rondebruin.nl/delete.htm#AutoFilter

Thanks Ron

That helped a little, but it was still very slow. After a bit more
trial and error, I added

Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2

before the 'Next c' line. This removed the filters and the code
speeded up by a factor of 10. It now takes less than 4 seconds to
loop through 20,000 + records and delete corresponding rows.

Not sure why this should make such a difference as the filters are
re-applied each time - but it did.

Thanks again

LS

 

[Ricky Pang]

Hi Ron,
I have a similar question; thus, please allow me to interject this
posting. Within your code, how do you alter the DeleteValue = "ron"
line to become; Delete all other items that Does Not begin with the
number "0"? The items that I want to retain are six numbers beginning
with zeros followed by a hypen and two alphanumeric characters...such as
012345-A1.

Lastly, what is does this line mean? If Not rng Is Nothing Then
rng.EntireRow.Delete
How does it differ from...? If Not rng Is Nothing Then rng.Delete
Shift:=xlUp

Thanks in Advance,
Ricky


The following is your code:
Sub Delete_with_Autofilter()
Dim DeleteValue As String
Dim rng As Range

DeleteValue = "ron"
' This will delete the rows with "ron" in column A

With ActiveSheet
.Columns("A").AutoFilter Field:=1, Criteria1:=DeleteValue
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete

'You can use this to delete only the cells with "ron" in
column A
'If Not rng Is Nothing Then rng.Delete Shift:=xlUp

End With
.AutoFilterMode = False
End With
End Sub

 

[Dave Peterson]

Sometimes it's quicker to record a macro when you do it manually:

I applied data|filter|autofilter, clicked on the dropdown, chose Custom and
chose does not begin, and typed 0.

I got this line:

Selection.AutoFilter Field:=1, Criteria1:="<>0*", Operator:=xlAnd

So you could change Ron's DeleteValue line to:
DeleteValue = "<>0*"

If you filter a list, the number of visible rows might be 0. (no row matching
the criteria).

So Ron checks it to see if it actually found something:

if not rng is nothing then
is pretty much like this in English (but not VBA!):
if rng is something then
(or if the autofilter found something, then...)

And one deletes just the single cell and shifts the cells up (leaving B:IV still
there for that row)
rng.delete shift:=xlup

and the other one deletes the row completely:
rng.entirerow.delete

But in an autofiltered range, I don't think the shift:=xlup works the way you'd
expect. It deleted the whole row for me. But I could remove the autofilter and
then delete just the cells.

Option Explicit
Sub Delete_with_Autofilter()
Dim DeleteValue As String
Dim rng As Range

DeleteValue = "ron"
' This will delete the rows with "ron" in column A

With ActiveSheet
.Columns("A").AutoFilter Field:=1, Criteria1:=DeleteValue
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'If Not rng Is Nothing Then rng.EntireRow.Delete

'You can use this to delete only the cells with "ron" in Column A
End With


'changed here:
.AutoFilterMode = False 'removes autofilter arrows
If Not rng Is Nothing Then rng.Delete Shift:=xlUp

'or even:
If Not rng Is Nothing Then
.ShowAllData 'keeps autofilter arrows
rng.Delete Shift:=xlUp
End If

End With
End Sub

 

[Ron de Bruin]

Hi Dave

But in an autofiltered range, I don't think the shift:=xlup works

I don't know why I add this lines there(To much beer I think)

Thanks for the correction

 

[Ricky Pang]

Thank-you so much Dave and Ron!
It worked. You've always been a reliable source of knowledge.

Thanks again,
Ricky