Tukukkk

The title is fairly self-explanatory re: my goals, though I'll add that speed/efficiency is a priority. Originally, I tried using an autofilter on the ListObject and deleting all visible rows. But that method was excruciatingly slow if the table had more than ~10k rows. In my testing of the current version on a table with 250k rows, it takes ~3 seconds to run on average.

Feedback on the helper methods is also welcome. You can assume that all of these subs are in the same module (along with a bunch of other ones) with Option Explicit at the top, and that Application.ScreenUpdating will already be set to False. (EDIT: Also assume that I'm using all of the other usual performance optimizations, ie setting calculation to manual).

Main Method:

Sub deleteRows(tbl As ListObject, critCol As String, critVal As Variant, Optional invert As Boolean = False, Optional exactMatch As Boolean = True)

'Deletes rows in a table (tbl) based on value criteria (critVal) in a given column (critCol) while maintaining original sort order

'Inverted setting deletes all rows *not* containing criteria

'Can search for exact match (default) or partial match



    Dim i As Long

    Dim ws As Worksheet

    Dim tempString As String

    Dim str1 As String

    Dim str2 As String



    Set ws = tbl.Parent



    'Use new column to record original sort order

    Call insertColumns(tbl, Array("DeleteRowsTemp", "DeleteRowsTemp2"), tbl.HeaderRowRange(tbl.ListColumns.Count).Value, "Right")

    Call addFormula(tbl, "DeleteRowsTemp", "=IF(R[-1]C[0]=""DeleteRowsTemp"",1,R[-1]C[0]+1)")



    If invert = False Then

        str1 = "Delete"

        str2 = "Keep"

    Else

        str1 = "Keep"

        str2 = "Delete"

    End If



    'Generate formula to determine which rows to delete

    If exactMatch = True Then

        If IsArray(critVal) = False Then

            tempString = "=IF("

            If IsNumeric(critVal) Then

                tempString = tempString & "[@[" & critCol & "]]=" & critVal

            Else

                tempString = tempString & "[@[" & critCol & "]]=" & """" & critVal & """"

            End If

            tempString = tempString & "," & """" & str1 & """," & """" & str2 & """)"

        Else

            tempString = "=IF(OR("

            For i = LBound(critVal) To UBound(critVal)

                If IsNumeric(critVal(i)) Then

                    tempString = tempString & "[@[" & critCol & "]]=" & critVal(i)

                Else

                    tempString = tempString & "[@[" & critCol & "]]=" & """" & critVal(i) & """"

                End If

                If i < UBound(critVal) Then

                    tempString = tempString & ","

                Else

                    tempString = tempString & ")," & """" & str1 & """," & """" & str2 & """)"

                End If

            Next

        End If

    Else

        tempString = "=IF(SUMPRODUCT(--(NOT(ISERR(SEARCH({"

        If IsArray(critVal) = False Then

            tempString = tempString & """" & critVal & """"

        Else

            For i = LBound(critVal) To UBound(critVal)

                tempString = tempString & """" & critVal(i) & """"

                If i < UBound(critVal) Then

                    tempString = tempString & ","

                End If

            Next

        End If

        tempString = tempString & "},[@[" & critCol & "]])))))," & """" & str1 & """," & """" & str2 & """)"

    End If



    'Add formula to second new column

    'Sort so that rows to be deleted are always at the bottom of the table, which...

    '...avoids bug that sometimes corrupts .xlsx files when deleting first row from table on same sheet as another table

    Call addFormula(tbl, "DeleteRowsTemp2", tempString)

    Call sortColumns(tbl, "DeleteRowsTemp2", xlDescending)



    Dim firstRow As Long

    Dim lastRow As Long

    Dim delStr As String



    delStr = "Delete"



    'Delete rows with "Delete" in the second new column (if they exist)

    If tbl.ListColumns(tbl.ListColumns.Count).DataBodyRange(tbl.ListRows.Count, 1) = delStr Then

        firstRow = tbl.ListColumns(tbl.ListColumns.Count).Range.Find(What:=delStr, after:=tbl.ListColumns(tbl.ListColumns.Count).Range(1), LookAt:=xlWhole).Row

        lastRow = tbl.ListColumns(tbl.ListColumns.Count).Range.Find(What:=delStr, after:=tbl.ListColumns(tbl.ListColumns.Count).Range(1), LookAt:=xlWhole, searchdirection:=xlPrevious).Row

        ws.Range(ws.Cells(firstRow, tbl.HeaderRowRange(1).Column), ws.Cells(lastRow, tbl.HeaderRowRange(1).Column + tbl.ListColumns.Count - 1)).Delete xlShiftUp

    End If



    'Restore table to original sort order and delete temporary columns

    'Deletes sheet columns rather than ListColumns to avoid bug...

    '...where ListColumns can't be deleted from table that is...

    '...on same sheet and to the left of longer table (ie has more rows)

    Call sortColumns(tbl, "DeleteRowsTemp", xlAscending)

    Call deleteSheetColumns(tbl, Array("DeleteRowsTemp", "DeleteRowsTemp2"))





End Sub

Helper Methods:

Sub insertColumns(tbl As ListObject, newCols As Variant, refCol As String, Optional direction As String = "Left")

'Inserts new column(s) (newCols) to the left or right of another column (refCol) in a table (tbl)



    Dim arrSize As Long

    Dim uCol As String



    If IsArray(newCols) Then

        arrSize = UBound(newCols) - LBound(newCols) + 1

        uCol = newCols(UBound(newCols))

    Else

        arrSize = 1

        uCol = newCols

    End If



    Dim ws As Worksheet

    Set ws = tbl.Parent



    Dim colNumWS As Long

    colNumWS = getColumn(tbl, refCol, , True)



    ws.Columns(colNumWS + 1).Resize(, arrSize).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    ws.Range(ws.Cells(tbl.HeaderRowRange(1).Row, colNumWS + 1), ws.Cells(tbl.HeaderRowRange(1).Row, colNumWS + arrSize)) = newCols



    If direction = "Left" Then

        Call moveColumns(tbl, refCol, uCol, "Right")

    End If



    tbl.Range.Columns.AutoFit



End Sub



Sub moveColumns(tbl As ListObject, colsToMove As Variant, refCol As String, Optional direction As String = "Left")

'Moves column(s) (colsToMove) to the left or right of another column (refCol) in a table (tbl)





    Dim toMove As Long

    Dim refColNum As Long

    Dim i As Long

    Dim ws As Worksheet

    Set ws = tbl.Parent



    If IsArray(colsToMove) = False Then

        toMove = tbl.ListColumns(colsToMove).Range.Column

        refColNum = tbl.ListColumns(refCol).Range.Column

        If direction = "Left" Then

            ws.Columns(toMove).Cut

            ws.Columns(refColNum).Insert Shift:=xlToRight

        ElseIf direction = "Right" Then

            ws.Columns(toMove).Cut

            ws.Columns(refColNum + 1).Insert Shift:=xlToRight

        End If

    Else

        If direction = "Left" Then

            For i = LBound(colsToMove) To UBound(colsToMove)

                toMove = tbl.ListColumns(colsToMove(i)).Range.Column

                refColNum = tbl.ListColumns(refCol).Range.Column

                ws.Columns(toMove).Cut

                ws.Columns(refColNum).Insert Shift:=xlToRight

            Next

        ElseIf direction = "Right" Then

            For i = UBound(colsToMove) To LBound(colsToMove) Step -1

                toMove = tbl.ListColumns(colsToMove(i)).Range.Column

                refColNum = tbl.ListColumns(refCol).Range.Column

                ws.Columns(toMove).Cut

                ws.Columns(refColNum + 1).Insert Shift:=xlToRight

            Next

        End If

    End If



End Sub



Sub addFormula(tbl As ListObject, col As String, newFormula As String, Optional col2 As String = "", Optional copyText As Boolean = True)

'Adds a formula (newFormula) to a column (col) in a table (tbl), then (optionally) copies the results of the formula in that range

'User can also specify another column (col2) to copy the results of the formula to

'Array formulas are supported by wrapping newFormula parameter with brackets



    Dim colNum As Long

    colNum = getColumn(tbl, col)

    'Enter formula and copy/paste results

    With tbl.ListColumns(col).DataBodyRange

        If Not Left(newFormula, 1) = "{" Then

            .FormulaR1C1 = newFormula

        Else

            newFormula = Mid(newFormula, 2, Len(newFormula) - 2)

            'This weird syntax avoids a bug that doesn't allow array formulas to be added directly to an entire ListColumn

            tbl.Range.Columns(colNum).Cells(2).FormulaArray = newFormula

            tbl.Range.Columns(colNum).Cells(2).AutoFill Destination:=tbl.ListColumns(col).DataBodyRange

        End If

        'Using Copy/PasteSpecial tested 15-20% faster than using DataBodyRange = DataBodyRange.Value

        If copyText = True Then

            .Copy

            .PasteSpecial Paste:=xlPasteValues

            If Not col2 = "" Then

                tbl.ListColumns(col2).DataBodyRange.PasteSpecial Paste:=xlPasteValues

            End If

            Application.CutCopyMode = False

        End If

    End With



End Sub



Function getColumn(tbl As ListObject, colName As Variant, Optional returnString As Boolean = False, Optional sheetColumn As Boolean = False)

'Returns column number (when returnString = False) or string (when returnString = True)

'of a provided column name (colName) in a table (tbl)

'Column number can refer to ListColumn number (when sheetColumn = False) or sheet column number (when sheetColumn = True)



    Dim colNum As Long



    If sheetColumn = False Then

        If returnString = False Then

            getColumn = Application.WorksheetFunction.Match(colName, tbl.HeaderRowRange, 0)

        Else

            colNum = Application.WorksheetFunction.Match(colName, tbl.HeaderRowRange, 0)

            getColumn = Split(tbl.Parent.Cells(1, colNum).Address, "$")(1)

        End If

    Else

        If returnString = False Then

            getColumn = tbl.HeaderRowRange(Application.WorksheetFunction.Match(colName, tbl.HeaderRowRange, 0)).Column

        Else

            colNum = tbl.HeaderRowRange(Application.WorksheetFunction.Match(colName, tbl.Parent.Rows(tbl.HeaderRowRange.Row), 0)).Column

            getColumn = Split(tbl.Parent.Cells(1, colNum).Address, "$")(1)

        End If

    End If



End Function



Sub sortColumns(tbl As ListObject, toSort As Variant, sOrder As Variant)

'Sorts columns (toSort) in a table (tbl) in a given order (sOrder)

'sOrder is either xlAscending (A to Z, smallest to largest) or xlDescending (Z to A, largest to smallest)

'Both toSort and sOrder can be arrays, but the function will cause an error if one of the following two conditions is not met:

  '1. toSort and sOrder are the same size (ie contain the same number of values)

  '2. toSort is an array and sOrder is a string

'The function will sort columns one after another, starting with the column in the first element in toSort





    Dim i As Long



    If IsArray(toSort) = False Then

        If IsArray(sOrder) = True Then

            MsgBox "Error: Size of sOrder array exceeds size of toSort array"

        Else

            With tbl.Sort

                .SortFields.Clear

                .SortFields.Add Key:=tbl.ListColumns(toSort).Range, _

                        SortOn:=xlSortOnValues, _

                        Order:=sOrder, _

                        DataOption:=xlSortNormal

                .Apply

            End With

        End If

    Else

        If IsArray(sOrder) = True Then

            If UBound(sOrder) = UBound(toSort) Then

                For i = LBound(toSort) To UBound(toSort)

                    With tbl.Sort

                        .SortFields.Clear

                        .SortFields.Add Key:=tbl.ListColumns(toSort(i)).Range, _

                                SortOn:=xlSortOnValues, _

                                Order:=sOrder(i), _

                                DataOption:=xlSortNormal

                        .Apply

                    End With

                Next

            Else

               MsgBox "Error: Size of sOrder array must be either 1 or equal to size of toSort array"

            End If

        Else

            For i = LBound(toSort) To UBound(toSort)

                With tbl.Sort

                    .SortFields.Clear

                    .SortFields.Add Key:=tbl.ListColumns(toSort(i)).Range, _

                            SortOn:=xlSortOnValues, _

                            Order:=sOrder, _

                            DataOption:=xlSortNormal

                    .Apply

                End With

            Next

        End If

    End If



End Sub

Answering my own question because there is a faster and simpler way to solve the problem assuming your table doesn't contain formulas. If that's a problem for you, I'd stick with the original answer. Thanks to Raystafarian for the suggestion to read the data into an array first.

My actual implementation is a bit shorter because it references a bunch of other functions I use regularly, but this answer is self-contained.

Function deleteRows(tbl As ListObject, ByVal critCol As String, ByVal critVals As Variant, Optional invert As Boolean = False) As Long

'Deletes rows in a table (tbl) based on value criteria (critVal) in a given column (critCol)

'Maintains original sort order

'Inverted setting deletes all rows *not* containing criteria

'Can search for partial matches by using wildcards with criteria



    'Get count of table rows/columns and exit function if table is empty

    Dim numCols As Long

    Dim numRows As Long

    numCols = tbl.ListColumns.Count

    numRows = tbl.ListRows.Count



    If numRows = 0 Then

        Exit Function

    End If



    'Get 2d array of table headers

    Dim headerArr As Variant

    If numCols = 1 Then

        ReDim headerArr(1 To 1, 1 To 1)

        headerArr(1, 1) = tbl.HeaderRowRange(1).Value2

    Else

        headerArr = tbl.HeaderRowRange.Value2

    End If



    Dim colToCheck As Long

    Dim colFound As Boolean

    Dim i As Long

    For i = 1 To numCols

        If headerArr(1, i) = critCol Then

            colToCheck = i

            colFound = True

            Exit For

        End If

    Next



    'If criteria column doesn't exist, exit sub

    If Not colFound Then

        MsgBox "Error: Column " & critCol & " does not exist in table"

        Stop

        Exit Function

    End If



    'Get 2d array of table data and create results array of same size

    'If table has no data, exit sub

    Dim bodyArr As Variant

    If numCols = 1 And numRows = 1 Then

        ReDim bodyArr(1 To 1, 1 To 1) As Variant

        bodyArr(1, 1) = tbl.DataBodyRange(1, 1).Value2

    Else

        bodyArr = tbl.DataBodyRange.Value2

    End If



    ReDim newArr(1 To numRows, 1 To numCols) As Variant



    'Turn criteria values into array

    Dim toCheck As Variant

    toCheck = IIf(IsArray(critVals), critVals, Array(critVals))



    'Loop through array, adding rows that meet criteria to new array

    Dim rowsKept As Long

    rowsKept = 0

    For i = 1 To numRows

        Dim toKeep As Boolean

        toKeep = Not invert

        Dim j As Long

        For j = LBound(toCheck) To UBound(toCheck)

            If bodyArr(i, colToCheck) Like toCheck(j) Then

                toKeep = invert

                Exit For

            End If

        Next

        If toKeep Then

            rowsKept = rowsKept + 1

            For j = 1 To numCols

                newArr(rowsKept, j) = bodyArr(i, j)

            Next

        End If

    Next



    Dim numDeleted As Long

    numDeleted = numRows - rowsKept

    If Not (numDeleted = 0) Then

        'Write new array to table

        tbl.DataBodyRange.Value2 = newArr



        'Delete empty rows from table

        Dim firstCol As Long

        Dim lastCol As Long

        Dim headerRow As Long

        firstCol = tbl.ListColumns(1).Range.Column

        lastCol = tbl.ListColumns(tbl.ListColumns.Count).Range.Column

        headerRow = tbl.HeaderRowRange(1).Row



        With tbl.Parent

            .Range(.Cells(rowsKept + headerRow + 1, firstCol), _

                   .Cells(tbl.ListRows.Count + headerRow, lastCol)).Delete xlShiftUp

        End With

    End If



    'Return count of rows deleted

    deleteRows = numDeleted



End Function