How to make loop code more efficient

M

macroapa

Hi,

I ahve the following code that loops thru each row and if the criteria
is met it deletes the row. However it runs really slowly. Is there a
way to acheive the same thing more effeiciently? Thanks

Sub removeNTUs()

Dim xR As Long
Dim xCw As Integer
Dim xCA As Integer
Dim wStep As String
Dim AStatus As String
Dim xStop As Long


xCw = 19
xCA = 20
xStop = Workbooks("pipeline reporting.xls").Worksheets
("variables").Cells(2, 2).Value + 12
xR = 15
Do
Debug.Print (xR)
wStep = Workbooks("pipeline reporting.xls").Worksheets
("Pipeline").Cells(xR, xCw).Value
AStatus = Workbooks("pipeline reporting.xls").Worksheets
("Pipeline").Cells(xR, xCA).Value

If wStep = "Diary - NTU" And AStatus = "Not Taken Up" Then
Rows(xR & ":" & xR).Delete Shift:=xlUp
xR = xR - 1
xStop = xStop - 1
End If
xR = xR + 1
Loop Until xR = xStop
MsgBox ("ended")
End Sub
 
M

Mike

macroapa said:
Hi,

I ahve the following code that loops thru each row and if the criteria
is met it deletes the row. However it runs really slowly. Is there a
way to acheive the same thing more effeiciently? Thanks

Sub removeNTUs()

Dim xR As Long
Dim xCw As Integer
Dim xCA As Integer
Dim wStep As String
Dim AStatus As String
Dim xStop As Long


xCw = 19
xCA = 20
xStop = Workbooks("pipeline reporting.xls").Worksheets
("variables").Cells(2, 2).Value + 12
xR = 15
Do
Debug.Print (xR)
wStep = Workbooks("pipeline reporting.xls").Worksheets
("Pipeline").Cells(xR, xCw).Value
AStatus = Workbooks("pipeline reporting.xls").Worksheets
("Pipeline").Cells(xR, xCA).Value

If wStep = "Diary - NTU" And AStatus = "Not Taken Up" Then
Rows(xR & ":" & xR).Delete Shift:=xlUp
xR = xR - 1
xStop = xStop - 1
End If
xR = xR + 1
Loop Until xR = xStop
MsgBox ("ended")
End Sub

Some ideas .... make sure that screen updating is off. Also, it might be
faster if you had a formula on the worksheet which tested for your
conditions and equated to true/false and use that to delete rows. Also,
when trundling with delete I usually work from the bottom up. I don't know
if that is faster or not. Finally, a completely different approach might by
to use and advance filter (in place) based on criteria.
Mike
 
R

Rick Rothstein

I think I interpreted your initial conditions correctly (first data row is
15, last row to delete up to is found on the "variables" sheet in B2). If
so, then see if this code is any faster than what you are running now...

Sub RemoveRows()
Dim X As Long
Dim xStop As Long
Dim OriginalCalculationMode As Long
Dim RowsToDelete As Range
Const xR As Long = 15
Const xCw As String = "S"
Const xCA As String = "T"
On Error GoTo Whoops
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Workbooks("pipeline reporting.xls")
xStop = .Worksheets("variables").Cells(2, 2).Value + 12
With .Worksheets("Pipeline")
xStop = .Cells(.Rows.Count, 1).End(xlUp).Row
For X = xStop To xR Step -1
If .Cells(X, xCw).Value = "Diary - NTU" And _
.Cells(X, xCA).Value = "Not Taken Up" Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(X, xCw)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(X, xCw))
End If
If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete xlShiftUp
Set RowsToDelete = Nothing
End If
End If
Next
End With
End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete xlShiftUp
End If
Whoops:
Application.Calculation = OriginalCalculationMode
Application.ScreenUpdating = True
MsgBox "Ended"
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top