Delete Rows Based ColA (multiple criteria)-Delete Rows based ColB (multiple criteria)

[elsg]

How make only one loop?

I need find criteria in col_A delete and col_B

Sub How_Make_Only_Loop()    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    'Loop 1
    For Each cell In Range("A16:A2000")
        Select Case cell.Value
        Case "CriteriaCol_A1", "CriteriaCol_A2", "CriteriaCol_A3"
            cell.EntireRow.Delete
        End Select
    Next cell
    'Loop 2
    For Each cell In Range("B16:B2000")
        Select Case cell.Value
        Case  "CriteriaCol_B1", "CriteriaCol_B2", "CriteriaCol_B3"
            cell.EntireRow.Delete
        End Select
    Next cell
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[fredlo2010]

Hi,

You could try this soltuion wihtout a loop

Sub NoLoopNeeded()    
    Dim rWork As Range
    
    ' Turn off extras
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
        
    Set rWork = Range("A1:B2000")
    
    
    'Filter the data.
    rWork.AutoFilter
    rWork.AutoFilter Field:=1, Criteria1:=Array("CriteriaCol_A1", "CriteriaCol_A2", "CriteriaCol_A3"), Operator:=xlFilterValues
    
    ' Delete visible rows.
    rWork.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    
    
    ' Filter the data in b.
    rWork.AutoFilter
    rWork.AutoFilter Field:=2, Criteria1:=Array("CriteriaCol_B1", "CriteriaCol_B2", "CriteriaCol_B3"), Operator:=xlFilterValues
    
     ' Delete visible rows.
    rWork.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    
    ' Remove the filter
    rWork.AutoFilter
    
    ' Clean up
    Set rWork = Nothing
    
    ' Turn on Extas.
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Or this other version a little more organized.

Sub ALittleMoreOrganizedCode()    
    Dim arrCriteriaA As Variant
    Dim arrCriteriaB As Variant
    Dim rWork As Range
    
    Call TurnExtrasOff
    
    ' Asign variables
    Set rWork = Range("A1:B2000")
    arrCriteriaA = Array("CriteriaCol_A1", "CriteriaCol_A2", "CriteriaCol_A3")
    arrCriteriaB = Array("CriteriaCol_B1", "CriteriaCol_B2", "CriteriaCol_B3")
   
    
    ' Delete the lines
    Call DeleteByCriteria(rWork, 1, arrCriteriaA)
    Call DeleteByCriteria(rWork, 2, arrCriteriaB)
    
    Call TurnExtrasOn
    
End Sub


Sub DeleteByCriteria(ByVal rData As Range, ByVal iField As Long, ByVal arrCriteria As Variant)
    
    With rData
        ' Filter the data.
        .AutoFilter
        .AutoFilter Field:=iField, Criteria1:=arrCriteria, Operator:=xlFilterValues
        
         ' Delete visible rows.
        .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        
        ' Clear the filter.
        rData.AutoFilter
    End With
    
        
    ' Clean up
    Set rData = Nothing
    Set arrCriteria = Nothing
    
End Sub
Sub TurnExtrasOff()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub


Sub TurnExtrasOn()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Hope this helps

[elsg]

Very fantastic!!

thank you very much!!