Optimize Macro

[had1015]

Hi,

I have the following macro which compares two worksheets column G (on both) and highlights where the same item on the second sheet (PMData) has its timeframe (column L) reduced. The macro works, however it takes anywhere from 10 to 15 minutes to run because it has to compare over nine thousand rows of data. If someone could please suggest a more efficient method of performing the same task I would be most appreciative.




Sub HiliteReduced()
Dim sh1 As Worksheet, sh2 As Worksheet, r1 As Range
Dim r2 As Range, cell1 As Range, cell2 As Range
Dim bFound As Boolean

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set sh1 = Worksheets("PMData")
Set sh2 = Worksheets("AMData")
Set r1 = sh1.Range(sh1.Cells(2, "G"), sh1.Cells(sh1.Rows.Count, "G").End(xlUp))
Set r2 = sh2.Range(sh2.Cells(2, "G"), sh2.Cells(sh2.Rows.Count, "G").End(xlUp))

For Each cell1 In r1
bFound = False
For Each cell2 In r2
If cell1 = cell2 And cell1.Offset(0, 5) < cell2.Offset(0, 5) Then
bFound = True
Exit For
End If
Next cell2
If bFound = True Then
With cell1.Offset(0, 5)
'.Value = 1
.Interior.ColorIndex = 4
End With
End If
Next cell1
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub



Thank you in advance for your assistance.

[Paul_Hossler]

Q: is the data sorted?

Q: does each value only occur one time?

Q: can you pose the WB with just the pertinent columns of data?

[had1015]

Yes the data is sorted and yes there is only one occurance. It will take some time for me to redact or clean up the workbook.

[jonh]

It would probably be quicker to incorporate a find into your second for loop (r2) instead of checking every row.
set cell2 = r2.find(...) then do the number check

You could also try a query to find the matches in the first place, e.g.


Sub getdups()
'change sheets and collumn names ...
Const col1 As String = "f1", _
col2 As String = "f2"

Const sht1 As String = "sheet1", _
sht2 As String = "sheet2"

Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.Open "DSN=Excel Files;DBQ=" & ActiveWorkbook.Path
sql = "SELECT `" & sht1 & "$`." & col1 & ", `" & sht1 & "$`." & col2 & ", `" & sht2 & "$`." & col1 & ", `" & sht2 & "$`." & col2 & " " & _
"FROM `" & ActiveWorkbook.FullName & "`.`" & sht1 & "$`, `" & ActiveWorkbook.FullName & "`.`" & sht2 & "$` " & _
"WHERE `" & sht1 & "$`." & col1 & " = `" & sht2 & "$`." & col1 & " AND `" & sht1 & "$`." & col2 & " > `" & sht2 & "$`." & col2 & " "
rs.Open sql, cn
Do Until rs.EOF
For Each f In rs.Fields
Debug.Print f.Value,
Next
rs.MoveNext
Debug.Print
Loop
rs.Close: cn.Close
End Sub

...and then use 'find' to format the values.

[mperrah]

Probably not a huge increase,
just eliminated one part of an if statement

Sub HiliteReduced()
Dim sh1, sh2 As Worksheet
Dim r1, r2, cell1, cell2 As Range

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Set sh1 = Worksheets("PMData")
Set sh2 = Worksheets("AMData")
Set r1 = sh1.Range(sh1.Cells(2, "G"), sh1.Cells(sh1.Rows.Count, "G").End(xlUp))
Set r2 = sh2.Range(sh2.Cells(2, "G"), sh2.Cells(sh2.Rows.Count, "G").End(xlUp))

For Each cell1 In r1
For Each cell2 In r2
If cell1 = cell2 And cell1.Offset(0, 5) < cell2.Offset(0, 5) Then
cell1.Offset(0, 5).Interior.ColorIndex = 4
Exit For
End If
Next cell2
Next cell1

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With

End Sub

[Paul_Hossler]

Not tested, but I usually use Match() for things like this





Option Explicit

Sub HiliteReduced_phh()
Dim sh1 As Worksheet, sh2 As Worksheet, r1 As Range
Dim r2 As Range, cell1 As Range, cell2 As Range
Dim iMatch As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set sh1 = Worksheets("PMData")
Set sh2 = Worksheets("AMData")
Set r1 = sh1.Range(sh1.Cells(2, "G"), sh1.Cells(sh1.Rows.Count, "G").End(xlUp))
Set r2 = sh2.Range(sh2.Cells(2, "G"), sh2.Cells(sh2.Rows.Count, "G").End(xlUp))

For Each cell1 In r1.Cells
iMatch = -1
On Error Resume Next
iMatch = Application.WorksheetFunction.Match(cell1.Value, r2, 0)
On Error GoTo 0

If iMatch > 0 Then
If cell1.Offset(0, 5).Value < r2.Cells(iMatch, 1).Offset(0, 5) Then
cell1.Offset(0, 5).Interior.ColorIndex = 4
End If
End If

Next cell1

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

[SamT]

@ Paul
If you encapsulate the loops inside a 'With WorksheetFunction', it will speed up the loops by eliminating ~18k of calls (dots.)

With Application.WorksheetFunction
For Each cell1 In r1.Cells
iMatch = -1
On Error Resume Next
iMatch = .Match(cell1.Value, r2, 0)
On Error GoTo 0

If iMatch > 0 Then
If cell1.Offset(0, 5).Value < r2.Cells(iMatch, 1).Offset(0, 5) Then
cell1.Offset(0, 5).Interior.ColorIndex = 4
End If
End If

Next cell1
End With

And I thimk that this might be a yet faster version.

With Application.WorksheetFunction
For Each cell1 In r1.Cells
On Error GoTo NextCheck

iMatch = .Match(cell1.Value, r2, 0)
If cell1.Offset(0, 5).Value < r2.Cells(iMatch, 1).Offset(0, 5) Then
cell1.Offset(0, 5).Interior.ColorIndex = 4
End If

NextCheck:
Next cell1
End With

[had1015]

Thank you all for taking the time assisting me. I tried all of your suggestions. When using jonh's code I get an error "[Microsoft] [ODBC Text Driver] Too few parameters. Expected:4. With mperrah's code I found little significant improvement. However, using Paul's and SamT's code was really awesome. I put a timer and it and it took only 2 to 3 seconds for each only in four attempts. Thank you all once again for this much improved time savings.

[Paul_Hossler]

@SamT


If you encapsulate the loops inside a 'With WorksheetFunction', it will speed up the loops by eliminating ~18k of calls (dots.)

Yes, 2 object references avoided per WS line.
My thoughts were to keep it simpler and have the objects close in the code.
Since it ran in 2-3 seconds shaving a couple of milliseconds didn't seem as important as easy to follow code (or at least I could easily follow it)




And I thimk that this might be a yet faster version.

I thimk you could be right on this also

However, I usually like to have the 'On Error Goto ....' in effect for as little time as possible
So I usually bracket the possible error causing statement(s) like that