I have a ListObject table with ~500 rows, I've also got 4 values in a named range.
There are maybe 30 unique values that occur repeatedly (At random) for the 500 rows, I want to delete all rows whose values are not in the named range.
I have the following which works, but it is running slower than expected (approximately 2 min):
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
I'm not sure whether it's the reliance on the worksheet function or just looping through the rows that is slowing it down.
Is there a way to filter the listobject and discard the rest?
I was thinking of just chucking a progress bar on it so that the users can see something happening...
Try this Code:
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
Your problem is not so much that you are looping through cells. It is in the fact that you are attempting to delete many discontiguous rows from a table; each one requiring internal reordering and restructuring of the ListObject table. Anything you can do to remove all of the rows at once will help and if you can delete them as a block it would be even better. Additionally, you may be recalculating whole columns of formulas repeatedly and redundantly.
You should find the following a scootch faster.
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
I ran this against 500 rows of sample data (A-Z) with A-D in the Included_Rows named range. It took 0.02 seconds.
Try this:
Dim Tbl As ListObject
Set Tbl = Sheets(indx).ListObjects(Tabla)
With Tbl
If .ListRows.Count >= 1 Then .DataBodyRange.Delete
End With
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.