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 :)
Very fantastic!!
thank you very much!!
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.