Delete entire rows on the basis of criteria-CodePudding

In my working file I want to delete entire rows from the table by using the criteria. The criteria is deleting all the rows except the "IMP" category in the "MODE" column. so, I did this my creating individual criteria of different categories. For instance if the mode is "FMD" then delete the entire column, if the mode is "HYD" then delete the entire column but my code is deleting only the first criteria that I have write in the below section. My code is not deleting all the modes that I have mentioned. I want to delete all the rows except "IMP" mode.Please guide me on this I will be very Thankful to you.

Sub DeleteRows()
    
    Const wsName As String = "Working"
    Const tblIndex As Variant = 1
    Const CriteriaColumnNumber As Long = 1
    Const Criteria As String = "HYD"
    Const Criteria1 As String = "DPL-2"
    Const Criteria3 As String = "TPM"
    Const Criteria4 As String = "DPL-3"
    Const Criteria5 As String = "GI"
    Const Criteria As String = "FMD"
    Const Criteria As String = "R&D"
    Const Criteria As String = "KYC"
   
    
    
    ' Reference the table.
    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(tblIndex)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Remove any filters.
    If tbl.ShowAutoFilter Then
        If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
    Else
        tbl.ShowAutoFilter = True
    End If
    
    ' Add a helper column and write an ascending integer sequence to it.
    Dim lc As ListColumn: Set lc = tbl.ListColumns.Add
    lc.DataBodyRange.Value = _
        ws.Evaluate("ROW(2:" & lc.DataBodyRange.Rows.Count & ")")
    
    ' Sort the criteria column ascending.
    With tbl.Sort
        .SortFields.Clear
        .SortFields.Add2 tbl.ListColumns(CriteriaColumnNumber).Range, _
            Order:=xlAscending
        .Header = xlYes
        .Apply
    End With

    ' AutoFilter.
    tbl.Range.AutoFilter Field:=CriteriaColumnNumber, Criteria1:=Criteria
    
    ' Reference the filtered (visible) range.
    Dim svrg As Range
    On Error Resume Next
        Set svrg = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' Remove the filter.
    tbl.AutoFilter.ShowAllData
  
    ' Delete the referenced filtered (visible) range.
    If Not svrg Is Nothing Then svrg.Delete
    
    ' Sort the helper column ascending.
    With tbl.Sort
        .SortFields.Clear
        .SortFields.Add2 lc.Range, Order:=xlAscending
        .Header = xlYes
        .Apply
        .SortFields.Clear
    End With
    
    ' Delete the helper column.
    lc.Delete
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Blanks deleted.", vbInformation
    
End Sub

This is the sample picture of my data

CodePudding user response：

Looping backwards:

Sub test()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim i As Long

Dim MyTable As ListObject: Set MyTable = ActiveSheet.ListObjects("Table1") 'change this according to your file

For i = MyTable.DataBodyRange.Rows.Count To 1 Step -1
    If MyTable.DataBodyRange.Cells(i, 1).Value <> "IMP" Then MyTable.DataBodyRange.Rows(i).Delete
Next i

Set MyTable = Nothing

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

After executing code:

Another option would be adding a helper column during code execution that will return X if MODE column is IMP, else it will return 1. Then delete all rows equal to 1 in this helper column and then delete the helper column. No loop, you can delete thousands of rows at one line of code.

Sub test()

Application.ScreenUpdating = False

Dim i As Long
Dim TableName As String: TableName = "Table1" 'change this according to your file
Dim MyTable As ListObject: Set MyTable = ActiveSheet.ListObjects(TableName)

MyTable.ListColumns.Add 'add new column to be used by formula

With MyTable.DataBodyRange.Columns(MyTable.ListColumns.Count)
    .FormulaR1C1 = "=IF(" & TableName & "[[#This Row],[MODE]]=""IMP"",""X"",1)"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, 1).Delete 'delete rows with no IMP
End With

MyTable.ListColumns(MyTable.ListColumns.Count).Delete 'delete helper column

Set MyTable = Nothing

Application.ScreenUpdating = True

End Sub

Anyways, if your selection is too big, this second method may not work, so your only way is deleting rows backwards

CodePudding user response：

A different approach using the FILTER function from Excel 365.

filtered data are written to an array (based on

Run the code and:

Edit: One other option, as I'm unsure if you want to list all of your cases, is to use Case Else such as:

Sub deleteNonIMP()
    With ThisWorkbook.Sheets(1)
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim rowNum As Long
        For rowNum = 1 To lastRow
            Select Case .Cells(rowNum, 2).Value
                Case "IMP"
                Case Else
                    Dim deleteRng As Range
                    If deleteRng Is Nothing Then
                        Set deleteRng = .Rows(rowNum)
                    Else
                        Set deleteRng = Union(deleteRng, .Rows(rowNum))
                    End If
            End Select
        Next rowNum
        If Not deleteRng Is Nothing Then deleteRng.Delete
    End With
End Sub

This would delete anything that is not "IMP".

and after running: