3

我有一个 ~500 行的 ListObject 表，我在一个命名范围内也有 4 个值。

对于 500 行，可能有 30 个唯一值重复（随机）出现，我想删除其值不在命名范围内的所有行。

我有以下工作，但运行速度比预期慢（大约 2 分钟）： 

Sub removeAccounts()

Dim tbl As ListObject
Dim i As Integer

Set tbl = ThisWorkbook.Sheets("TheSheet").ListObjects("TheTable")

i = tbl.ListRows.Count


While i > 0
  If Application.WorksheetFunction.CountIf(Range("Included_Rows"), tbl.ListRows(i).Range.Cells(1).Value) = 0 Then
    tbl.ListRows(i).Delete
  End If
  i = i - 1
Wend

End Sub

我不确定是对工作表函数的依赖还是只是循环遍历减慢了它的行。

有没有办法过滤 listobject 并丢弃其余的？

我正在考虑只是在其上放置一个进度条，以便用户可以看到正在发生的事情......

4

4 回答 4

4

试试这个代码：

Sub removeAccounts()

 Dim tbl As ListObject
 Dim i As Long
 Dim uRng As Range

 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual


 Set tbl = ThisWorkbook.Sheets("TheSheet").ListObjects("TheTable")

 i = tbl.ListRows.Count


 While i > 0
   If Application.WorksheetFunction.CountIf(Range("Included_Rows"), tbl.ListRows(i).Range.Cells(1).Value) = 0 Then

      'tbl.ListRows(i).Delete
      If uRng Is Nothing Then
       Set uRng = tbl.ListRows(i).Range
      Else
       Set uRng = Union(uRng, tbl.ListRows(i).Range)
      End If
   End If
   i = i - 1
 Wend

  If Not uRng Is Nothing Then uRng.Delete xlUp

 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic

 End Sub
于 2015-12-21T02:19:25.677 回答
2

您的问题不在于您正在循环遍历单元格。事实上，您正试图从表中删除许多不连续的行；每一个都需要对 ListObject 表进行内部重新排序和重组。您可以立即删除所有行的任何操作都会有所帮助，如果您可以将它们作为一个块删除，那就更好了。此外，您可能会重复且冗余地重新计算整列公式。

您应该更快地找到以下内容。

Sub removeAccounts()

    Dim i As Long

    Debug.Print Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook.Sheets("TheSheet")
        With .ListObjects("TheTable")
            '.Range.Columns(2).Delete
            .Range.Columns(2).Insert
            With .DataBodyRange.Cells(1, 2).Resize(.DataBodyRange.Rows.Count, 1)
                .FormulaR1C1 = "=isnumber(match(RC[-1], Included_Rows, 0))"
                .Calculate
            End With
            .Range.Cells.Sort Key1:=.Range.Columns(2), Order1:=xlDescending, _
                              Orientation:=xlTopToBottom, Header:=xlYes
            With .DataBodyRange
                i = Application.Match(False, .Columns(2), 0)
                Application.DisplayAlerts = False
                .Cells(i, 1).Resize(.Rows.Count - i + 1, .Columns.Count).Delete
                Application.DisplayAlerts = True
            End With
            .Range.Columns(2).Delete
        End With
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Debug.Print Timer

End Sub

我在Included_Rows命名范围内使用 AD 对 500 行样本数据 (AZ) 运行此程序。耗时 0.02 秒。

于 2015-12-21T04:36:00.737 回答
0

尝试这个：

Dim Tbl As ListObject
Set Tbl = Sheets(indx).ListObjects(Tabla)

With Tbl

If .ListRows.Count >= 1 Then .DataBodyRange.Delete

End With
于 2016-05-12T15:01:57.770 回答
0

Use code like this to delete all but the first row in a list object. By deleting the entire row, it also resizes the table appropriately. tblData is a ListObject variable pointing to an existing table/listobject.

tblData.DataBodyRange.Offset(1, 0).EntireRow.Delete

Of course, you can't have data to the left or right of a table since it will also be deleted. But this is MUCH faster than looping.

于 2016-10-29T17:55:27.617 回答