CODEWITHSUNDEEP
excelvba
Shawn H
Shawn H

Reputation: 1118

How to delete rows in an Excel ListObject based on criteria using VBA?

I have a table in Excel called tblFruits with 10 columns and I want to delete any rows where the Fruit column contains Apple. How can I do this?

Upvotes: 10

Views: 24853

Answers (2)

FCastro
FCastro

Reputation: 631

Well, it seems the .listrows property is limited to either ONE list row or ALL list rows.

Easiest way I found to get around this was by:

  1. Setting up a column with a formula that would point out to me all rows I would like to eliminate (you may not need the formula, in this case)

  2. Sorting the listobject on that specific column (preferably making it so that my value to be deleted would be at the end of the sorting)

  3. Retrieving the address of the range of listrows I will delete

  4. Finally, deleting the range retrieved, moving cells up.

In this specific piece of code:

Sub Delete_LO_Rows
    Const ctRemove as string = "Remove" 'value to be removed
    Dim myLO as listobject, r as long
    Dim N as integer 'number of the listcolumn with the formula

    Set myLo = Sheet1.ListObjects("Table1") 'listobject goes here

    With myLO
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=.HeaderRowRange(myLO.ListColumns(N)), SortOn:= _
                xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With        
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        On Error GoTo NoRemoveFound
        r = Application.WorksheetFunction.Match(ctRemove, .ListColumns(.ListColumns.Count).DataBodyRange, 0)
        Range(.parent.name & "!" & .DataBodyRange(r, 1).Address & ":" & .DataBodyRange(.ListRows.Count, .ListColumns.Count).Address).Delete xlShiftUp
'Added the .parent.name to make sure the address is on the correct sure, but it will fail if there are any spaces or characters on the sheet name that will make it need a pair of '.
'The error is just to skip these two lines in case the match returns an error. There's likely a better/cleaner way to do that.
NoRemoveFound:
    End With
End sub

Hope it helps...

Upvotes: 3

Shawn H
Shawn H

Reputation: 1118

The following sub works:

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

The sub can be executed like this:

Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("tblFruits")
Call deleteTableRowsBasedOnCriteria(tbl, "Fruit", "Apple")

Upvotes: 14

Related Questions