excel Delete rows from table Macro based on criteria - excel

Question

My Question: I am trying to delete rows in a table in column AH and Criteria is "Del" so any cell in column AH, I want to delete entire row in that table.
I tried so many different codes and most take forever as I have 10000+ rows to delete. I found this code from a site, but I am getting an error subscript out of range Error9 from the If Intersect line:
Private Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, _
columnName As String, _
criteria As String)
Dim x As Long, lastrow As Long, lr As ListRow
lastrow = tbl.ListRows.Count
For x = lastrow To 1 Step -1
Set lr = tbl.ListRows(x)
If Intersect(lr.Range, tbl.ListColumns(columnName).Range).Value = criteria Then
'lr.Range.Select
lr.Delete
End If
Next x
End Sub
Then I called the sub as below:
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table4")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del")
Any help would be great. Thank you.

Answer 1

You should be able to just use AutoFilter instead of a loop. It is much faster.
Sub Macro1()
Dim wks As Worksheet
Dim tbl As ListObject
Dim lastRow As Long
Dim rng As Range
Set wks = ActiveWorkbook.Sheets("Sheet1")
Set tbl = wks.ListObjects("Table4")
' Filter and delete all rows that have "Del" in it
With tbl.Range
' Switch off the filters before turning it on
.AutoFilter
' Field:=34 must be equal to the column where you have the criteria in
.AutoFilter Field:=34, Criteria1:="Del"
' Set the range for the filtered cells
Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.AutoFilter ' Turn off the filter
rng.Delete ' Delete the filtered cells
End With
End Sub

Answer 2

I changed your code a little bit and added a button to execute the delete rows function. I use the buttons caption to display how many rows have been deleted so you know what is happening. The key is to call DoEvents so everything is refreshed and have the button caption changed while the rows are being deleted:
You add a button CommandButton1 and try this code:
Private Sub CommandButton1_Click()
Dim rowsDeleted As Long
Call deleteTableRowsBasedOnCriteria("H", "Del")
End Sub
Private Sub deleteTableRowsBasedOnCriteria(columnName As String, criteria As String)
Dim x As Long, lastrow As Long, lr As ListRow, rowsDeleted As Long, deletedShift As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
rowsDeleted = 0
deletedShift = 0
For x = lastrow To 1 Step -1
If Cells(x, Range(columnName & 1).Column) = "Del" Then
Rows(x).Delete
rowsDeleted = rowsDeleted + 1
deletedShift = deletedShift + 1
If deletedShift >= 30 Then
CommandButton1.Caption = "Deleted " & rowsDeleted & " rows"
deletedShift = 0
DoEvents
End If
End If
Next x
MsgBox "Total rows deleted: " & rowsDeleted
End Sub

Answer 3

On large Datasets like this I prefer to use arrays instead of deleting rows. The concept is pretty simple you load your Target cell values into an array (Data) and then create a second empty array the same size (NewData). Next you loop through the Data and copy any rows of Data that you want to keep the next empty row in NewData. Finally you overwrite the Target cell values with the NewData, effectively deleting the rows that you didn't want to keep.
I actually went a step further here by adding a PreserveFormulas parameter. If PreserveFormulas = True then the formulas are copied to the NewData, instead of just the values.
Note: 59507 rows deleting every other row. I compare Array Delete Data Only, Array Delete Preserve Formulas, Union Method and Filter Method. Download Test Stub
Results
Test
Sub Test()
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del", False)
Debug.Print
Set tbl = ThisWorkbook.Worksheets("Sheet2").ListObjects("Table13")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del", True)
End Sub
Code
Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, columnName As String, criteria As String, PreserveFormulas As Boolean)
Dim Start: Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Data, Formulas, NewData
Dim col As Long, pos As Long, x As Long, y As Long
col = Columns(columnName).Column
Data = tbl.DataBodyRange.Value
If PreserveFormulas Then Formulas = tbl.DataBodyRange.Formula
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 1 To UBound(Data, 1)
If Data(x, col) <> criteria Then
pos = pos + 1
For y = 1 To UBound(Data, 2)
If PreserveFormulas Then
NewData(pos, y) = Formulas(x, y)
Else
NewData(pos, y) = Data(x, y)
End If
Next
End If
Next
tbl.DataBodyRange.Formula = NewData
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print "Preserve Formulas: "; PreserveFormulas
Debug.Print "Original RowCount: "; UBound(Data, 1); " Column Count: "; UBound(Data, 2)
Debug.Print "New RowCount: "; pos
Debug.Print UBound(Data, 1) - pos; " Rows Deleted"
Debug.Print "Execution Time: "; Timer - Start; " Second(s)"
End Sub