PDA

View Full Version : [SOLVED] Delete Rows Based ColA (multiple criteria)-Delete Rows based ColB (multiple criteria)



elsg
12-04-2014, 11:41 AM
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
12-04-2014, 12:12 PM
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
12-04-2014, 12:15 PM
Very fantastic!!

thank you very much!!