VBA (Optimization) Help to replace inefficient Do .. Loops ...

[Philip]

Hi,

I have several Do.. Loops in different Case statements in a sub like this:[P3].Select

' Autofilter didn't work properly, so deleting ALL non-SETL
rows...
' FOR THIS REASON, it is important to run the SETTLED LAST !!!
Do Until ActiveCell.Text = ""

If ActiveCell.Text <> "SETL" Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If

Loop

'hide the lines with the excluded broker numbers
[S3].Select

Do Until ActiveCell.Text = ""
For iExCount = 0 To UBound(iExcludedBrks)
If ActiveCell.Text = iExcludedBrks(iExCount) Then
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Exit For
End If
Next
ActiveCell.Offset(1, 0).Select
Loop

Columns("R:R").Hidden = False ' LAST UPDATE COLUMN MUST NOT BE HIDDEN !!!
[R3].Select

' first loop, delete ALL rows with LAST UPDATE before LAST RUN, as these are
ALL SETTLED !
Do Until ActiveCell.Text = ""
NextDate:
If ActiveCell.Text = "" Then Exit Do
iTestDate = CDate(Format(VBA.Left(VBA.Trim(ActiveCell.Text),
4) & "/" & VBA.Mid(VBA.Trim(ActiveCell), 5, 2) & "/" &
VBA.Mid(VBA.Trim(ActiveCell), 7, 2), "Short Date"))

If iTestDate < CDate(sLastUpdateDate) Then
' this LAST UPDATE was before LAST RUN DATE , so now time check required,
delete
ActiveCell.EntireRow.Delete shift:=xlUp

GoTo NextDate
End If
ActiveCell.Offset(1, 0).Select

Loop

[R3].Select
' now we have deleted ALL activity that settled BEFORE the LAST RUN, so with
the remainder,
' check the time part of the LAST UPDATE FIELD AGAINST TIME LAST RUN !!!
' Modified PWL 2002 02 26
' To force a test of BOTH conditions ...
' Both the DATE of LAST UPDATE AND TIME LAST UPDATE in MCH MUST
be before LAST RUN date/time
' for a record to be deleted...
Do Until ActiveCell.Text = ""
NextTime:
If ActiveCell.Text = "" And ActiveCell.Offset(1, 0).Text =
"" Then Exit Do

' iTestTime = TimeValue(VBA.Left(VBA.Right(VBA.Trim(ActiveCell.Text), 6),
2) & ":" & VBA.Mid(VBA.Right(VBA.Trim(ActiveCell.Text), 6), 3, 2) & ":" &
VBA.Right(VBA.Right(VBA.Trim(ActiveCell.Text), 2), 6))

' it tests the values of the 'seconds' part of the DATE TIME LAST UPDATE
field from
' MCH, and if that is >= 60 then it is replaced by 59.
' CHANGED PWL, Aug 2003 for MCH Issue in CTDA/BTDA...
If VBA.Right(VBA.Right(VBA.Trim(ActiveCell.Text), 2), 6) >= 60 Then
iTestTime =
VBA.TimeValue(VBA.Left(VBA.Right(VBA.Trim(ActiveCell.Text), 6), 2) & ":" &
VBA.Mid(VBA.Right(VBA.Trim(ActiveCell.Text), 6), 3, 2) & ":59")
Else
iTestTime =
VBA.TimeValue(VBA.Left(VBA.Right(VBA.Trim(ActiveCell.Text), 6), 2) & ":" &
VBA.Mid(VBA.Right(VBA.Trim(ActiveCell.Text), 6), 3, 2) & ":" &
VBA.Right(VBA.Right(VBA.Trim(ActiveCell.Text), 2), 6))
End If
iTestDate = CDate(Format(VBA.Left(VBA.Trim(ActiveCell.Text), 4) & "/" &
VBA.Mid(VBA.Trim(ActiveCell), 5, 2) & "/" & VBA.Mid(VBA.Trim(ActiveCell), 7,
2), "Short Date"))

' check the last UPDATE TIME OF THE RECORD against LAST RUN TIME
' BY THE SECOND !!!
If (iTestTime < TimeValue(sLastUpdateTime)) And (iTestDate =
CDate(sLastUpdateDate)) Then
' e.g. IF time of LAST RUN was 09:01:00 and Time LAST UPDATE was 09:00:59
' THEN THAT ROW WILL BE DELETED !!!
' Time of last update was BEFORE last run, so delete
this row!
ActiveCell.EntireRow.Delete shift:=xlUp
GoTo NextTime
End If
ActiveCell.Offset(1, 0).Select
Loop

<<< END CODE >>>

I am sure there must be a better way... for example, I have a list of
brokers to exclude from the report in an array, and for each row I check all
the brokers...

I'd be gratefule for any help to replace this with more efficeint code in
case there are many thousands of trades being checked...

thanks

Philip

 

[JE McGimpsey]

This is untested, but I believe it will do what your loops do in one
pass through the data:

Public Sub Test()
Dim iExcludedBrks As Variant
Dim rCell As Range
Dim rDelete As Range
Dim iTestTime As Double
Dim iExCount As Long
Dim iTestDate As Long
Dim sLastUpdateDate As String
Dim sLastUpdateTime As String
Dim sTemp As String
Dim bDelete As Boolean

'Setup stuff here

For Each rCell In Range("P3" & _
Range("P" & Rows.Count).End(xlUp).Row)
With rCell
If .Text <> "SETL" Then
bDelete = True
Else
With .Offset(0, 1)
For iExCount = LBound(iExcludedBrks) To _
UBound(iExcludedBrks)
If .Text = iExcludedBrks(iExCount) Then
bDelete = True
Exit For
End If
Next iExCount
End With
If Not bDelete Then
sTemp = Trim(.Offset(0, 2).Text)
iTestDate = CDate(Left(sTemp, 4) & "/" & _
Mid(sTemp, 5, 2) & "/" & Mid(sTemp, 7, 2))
If iTestDate < CDate(sLastUpdateDate) Then
bDelete = True
Else
sTemp = Right(sTemp, 6)
iTestTime = TimeValue(Left(sTemp, 2) & ":" & _
Mid(sTemp, 3, 2) & ":" & _
Application.Min(59, CLng(Right(sTemp, 2))))
If iTestTime < TimeValue(sLastUpdateTime) Then _
bDelete = True
End If
End If
End If
End With
If bDelete Then
If rDelete Is Nothing Then
Set rDelete = rCell
Else
Set rDelete = Union(rDelete, rCell)
End If
End If
Next rCell
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End Sub