I am trying to sort a table by deleting rows that have their cell in column 9 NOT beginning with S, X, or P. Below is the code that I have that filters for the rows that do not meet my criteria, and then deletes them, and then shows the remaining values.

Range("I:I").NumberFormat = "@"

    lo.Range.AutoFilter Field:=9, Criteria1:=Array("<>S*", "<>X*", "<>P*"), Operator:=xlOr
   
    Application.DisplayAlerts = False
     lo.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    
    lo.AutoFilter.ShowAllData

Currently, regardless or order, only rows that contain the last criteria in the array are kept.

CodePudding user response：

This code will delete any rows that have a value in the 9th column of the first table on the first sheet in a workbook that doesn't start with one of the letters in arrBeginsWith.

There are other ways to do achieve what you want, for example adding a helper column that identifies the rows to delete with a formula and then filtering on that column.

Option Explicit

Sub KeepRowsStartingWith()
Dim tbl As ListObject
Dim rngDelete As Range
Dim arrBeginsWith As Variant
Dim arrData As Variant
Dim idxRow As Long
Dim StartRow As Long
Dim Res As Variant

    Set tbl = Sheets(1).ListObjects(1)
    
    With tbl.ListColumns(9).DataBodyRange
        StartRow = .Cells(1, 1).Row
        arrData = .Value
    End With
    
    ReDim arrDeleteRows(1 To UBound(arrData, 1))
    
    arrBeginsWith = Array("S", "X", "P")
    
    For idxRow = 1 To UBound(arrData, 1)
    
        Res = Application.Match(Left(arrData(idxRow, 1), 1), arrBeginsWith, 0)
        
        If IsError(Res) Then
            If rngDelete Is Nothing Then
                Set rngDelete = Intersect(tbl.DataBodyRange, Sheets(1).Rows(idxRow   StartRow - 1))
            Else
                Set rngDelete = Union(rngDelete, Intersect(tbl.DataBodyRange, Sheets(1).Rows(idxRow   StartRow - 1)))
            End If
        End If
        
    Next idxRow

    rngDelete.Delete xlShiftUp
    
End Sub

CodePudding user response：

Delete Multi-Criteria Rows of an Excel Table

• You cannot have more than two criteria (elements) with wild characters.
• As a workaround, this solution adds a new column and writes a formula to it. The formula returns a boolean indicating whether a string starts with the chars from the list. Then it filters the new column by False and deletes these filtered tables' (not worksheet's) rows. Finally, it deletes the new column.
• The data to the right (one empty column is assumed) stays intact, it is not shifted in any way hence the inserting and deleting of a worksheet column instead of using .ListColumns.Add.
• Adjust the values in the constants section.

Option Explicit

Sub DeleteMultiCriteriaRows()
    
    Const wsName As String = "Sheet1"
    Const tblName As String = "Table1"
    Const NotFirstCharList As String = "s,x,p"
    Const CritCol As Long = 9
    
    ' Extract chars for the formula.
    Dim Nfc() As String: Nfc = Split(NotFirstCharList, ",")
    Dim NotFirstChar As String: NotFirstChar = "{"
    Dim n As Long
    For n = 0 To UBound(Nfc)
        NotFirstChar = NotFirstChar & """" & Nfc(n) & ""","
    Next n
    NotFirstChar = Left(NotFirstChar, Len(NotFirstChar) - 1) & "}"
    Erase Nfc
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim tbl As ListObject: Set tbl = ws.ListObjects(tblName)
    
    Application.ScreenUpdating = False
    
    With tbl
        
        .ShowAutoFilter = False ' remove filter (but also arrows)
        
        .ListColumns(CritCol).DataBodyRange.NumberFormat = "@" ' ?
        
        Dim nFormula As String
        nFormula = "=ISNUMBER(MATCH(LEFT(" & .Name & "[@" _
            & .ListColumns(CritCol).Name & "],1)," & NotFirstChar & ",0))"
        
        Dim LastCol As Long: LastCol = .ListColumns.Count
        With .ListColumns(1) ' write formulas to newly inserted column
            .Range.Offset(, LastCol).EntireColumn.Insert
            .DataBodyRange.Offset(, LastCol).Formula = nFormula
        End With
        
        LastCol = LastCol   1 ' think new column
        .Range.AutoFilter LastCol, False ' think Not(FirstChar)
        
        Dim vrg As Range ' Visible Range
        On Error Resume Next ' prevent 'No cells found...' error
            Set vrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        .Range.AutoFilter ' remove filter (toggle arrows)
        
        If Not vrg Is Nothing Then ' delete visible rows
            vrg.Delete Shift:=xlShiftUp
        End If
        
        .ListColumns(LastCol).Range.EntireColumn.Delete ' delete new column
        .ShowAutoFilter = True ' show arrows
    
    End With
    
    Application.ScreenUpdating = True
    
End Sub