Need to make code faster: delete unfiltered/hidden rows

[Faintkitara]

So I found and manipulated code that Autofilters a specific column by criteria (if name is John) and finally deletes all of the other rows that don't have that name. Seems pretty easy but my code takes an entire 50 seconds to run which is wayyyy to long.

Is there a way to rewrite this code that makes it faster but does the same thing?

Sub FilterandDelete

Dim i As Integer, rngData As Range

Set rngData = Worksheets("Backlog").Range("A4")
i = Application.WorksheetFunction.Match("Leader", Range("A4:JD4"), 0)
rngData.AutoFilter Field:=i, Criteria1:="John"


    Dim lRows As Long
    Application.Calculation = xlCalculationManual
    For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
    Next lRows
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Rick Rothstein]

When doing this previously, I found a massive speed impact was the deletion of non-contiguous rows as, after each row deletion, Excel needs to shuffle the remaining rows below.

That should not be a problem with the method I used in the code I posted in Message #18 as all the rows, contiguous or not, get deleted at the same time.

 

[Faintkitara]

Thank You @Rick! This actually works! The only problem I have is that the code seems to delete the header row on row 4 which I kinda use as an identifier for another macro. It would also be really cool if you could put a few comments in between the code so that I can learn how you did it as well (if you cant thats ok, I appreciate the help!)

 

[Faintkitara]

@Jonmo1 So I tried your code and it asked to delete the entire sheet row. At first I thought this would delete everything but i clicked yes and everything seems to be filtered and deleted quickly!

My only problem is that at the last two rows of the sheet, it still has two names that are not John which is kinda weird. I think this may have something to do with my headers being on row 4 and not 1... i think...

 

[Faintkitara]

@Rory: It says "No cells were found"...

 

[Jonmo1]

The 2 at the end being missed is likely due to each column having different ending points.
So the code used the Leader column to define the last row.
But there must be another column in the range that has more rows than the Leader column.

Try this instead
Application.Intersect(Worksheets("Backlog").UsedRange, rngData.Offset(1).Resize(rngData.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow).Delete

 

[RoryA]

@Rory: It says "No cells were found"...

Is the first column of your data hidden?

 

[Faintkitara]

@Jonmo1 This is perfect. Everything works, I appreciate your work. I'm gonna try it with similar data and hopefully it will work just like it did this set of data.

 

[Jonmo1]

Great, glad to hear it.

Here's a tidied up version.
I think the lastrow variable might have been off for the same reason that caused the 2 extra not john in the previous code.

Sub FilterandDelete()
Dim lr As Long, i As Long, rngData As Range

Application.Calculation = xlCalculationManual
With Worksheets("Backlog")
    i = Application.Match("Leader", .Range("A4:JD4"), 0)
    lr = .UsedRange.Rows.Count + .UsedRange.Row - 1
    Set rngData = .Range("A4:JD" & lr)
    
    rngData.AutoFilter Field:=i, Criteria1:="<>John"
    On Error Resume Next
    Application.Intersect(.UsedRange, rngData.Offset(1).Resize(rngData.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow).Delete shift:=xlUp
    On Error GoTo 0
    rngData.AutoFilter
End With
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Rick Rothstein]

Thank You @Rick! This actually works! The only problem I have is that the code seems to delete the header row on row 4...

A silly mistake on my part which I have corrected below. Actually, in reviewing the code, I found a small error that would have cropped up if you ever changed the header row from Row 4, but I have corrected that as well.

It would also be really cool if you could put a few comments in between the code so that I can learn how you did it as well...

Sure... here you go (this is the corrected code that you should use if you choose to implement my method).

[table="width: 500"]
[tr]
	[td]Sub FilterAndDelete()
  Dim LastRow As Long, UnusedCol As Long, LeaderCol As Long, KeepMe As String
[COLOR="#008000"]  '  Defines where the header row is[/COLOR]
  Const HeaderRow As Long = 4
[COLOR="#008000"]  '  Sets the text for the rows you want to keep[/COLOR]
  KeepMe = "John"
[COLOR="#008000"]  '  Finds the column where the header labeled "Leader" is located[/COLOR]
  LeaderCol = Rows(HeaderRow).Find("Leader", , , xlWhole, , , False).Column
[COLOR="#008000"]  '  Finds the last row with data on the sheet no matter what column it is in[/COLOR]
  LastRow = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
[COLOR="#008000"]  '  Finds the column after the last used column to be used as a helper column[/COLOR]
  UnusedCol = Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
[COLOR="#008000"]  '  Turn off screen updating so the user does not see the manipulations that take place[/COLOR]
  Application.ScreenUpdating = False
[COLOR="#008000"]  '  The Evaluate function evaluates an Excel formula and returns an array of
  '  results which are distributed down the helper column through all the rows
  '  in use. Here, the formula puts a 1 in a cell if that row does not contain
  '  the KeepMe word ("John" in this case), otherwise the cell stays blank[/COLOR]
  Range(Cells(HeaderRow + 1, UnusedCol), Cells(LastRow, UnusedCol)) = Evaluate("IF(H" & HeaderRow & ":H28=""" & KeepMe & ""","""",1)")
[COLOR="#008000"]  '  Turns off automatic calculation so things are not slowed down by individual formula recalculations[/COLOR]
  Application.Calculation = xlCalculationManual
[COLOR="#008000"]  '  Here we locate all the constants (the number 1 the Evaluate function
  '  placed earlier) and delete the entire row where those constants are[/COLOR]
  Columns(UnusedCol).SpecialCells(xlConstants).EntireRow.Delete
[COLOR="#008000"]  '  Turn calculations back on so Excel can catch all the formulas up[/COLOR]
  Application.Calculation = xlCalculationAutomatic
[COLOR="#008000"]  '  Turn screen updating on agains so the user can see the results[/COLOR]
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

 

[Faintkitara]

@Jonmo1 Wow this code is even faster. My code went from 45 seconds to work to like 1 second.. LOL YOU SAVED MY BUTT THANKSSSS.