7
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ You should also disable Events, change Calculation to manual before deleting, then restore afterwards. What makes it slow is that a calculation is required every time you delete a row. \$\endgroup\$ – PatricK Dec 20 '17 at 23:55
  • \$\begingroup\$ By "Assume that Application.ScreenUpdating will already be set to False" I meant "Assume that I'm using all of the usual performance optimizations, ie disabling calculation/screen updating/etc.". Edited the post to clarify. Regardless, this is not "what makes it slow" in my case, because the tables/workbooks I was testing had no formulas except when I explicitly added them/immediately copied their results using the "addFormula" sub. I'm not even sure what you mean by "makes it slow", unless you know of some macro that deletes rows from a 250k-row table based on criteria in <3 seconds. \$\endgroup\$ – Daniel McCracken Dec 21 '17 at 16:39
1
\$\begingroup\$

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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.