如何使用 VBA 根据条件删除 Excel ListObject 中的行？

Question

我在 Excel 中有一个名为 tblFruits 的表，它有 10 列，我想删除 Fruit 列包含 Apple 的所有行。我该怎么做？

Answer 1

以下子作品：

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

sub 可以这样执行：

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

Answer 2

嗯，.listrows 属性似乎仅限于一个列表行或所有列表行。

我发现解决此问题的最简单方法是：

1. 使用公式设置列，向我指出我想删除的所有行（在这种情况下，您可能不需要公式）

2. 对特定列上的 listobject 进行排序（最好是这样，以便我要删除的值在排序结束时）

3. 检索我将删除的列表行范围的地址

4. 最后，删除检索到的范围，向上移动单元格。

在这段特定的代码中：

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

希望对你有帮助...