excel Delete rows from table Macro based on criter

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

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 2

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

Answer 3

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