PDA

View Full Version : Solved: Combined loop and find method between 2 sheets is too slow.



frank_m
02-08-2012, 10:09 PM
I wrote the code below to find if Sht1 ColB value is found in Sht2 ColB, then if found and if corresponding ColA value in Sht2 = "P", fill in the "P" in Sht1 and color that cell red. --- Also fill in corresponding ColAF value.

There are only 2,204 rows in the sample attached file and it takes about 4 seconds to run.

I'm hoping someone will help reduce that time substantially as I need to run this on over 20,000 records.

Thanks
Private Sub CommandButton1_Click()

Dim Wks1 As Worksheet, Wks2 As Worksheet, Rng1 As Range, Rng2 As Range
Dim cll As Range, LRowWks1 As Long, LRowWks2 As Long
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")

LRowWks1 = Wks1.Cells(Wks1.Rows.Count, "B").End(xlUp).Row
LRowWks2 = Wks2.Cells(Wks2.Rows.Count, "B").End(xlUp).Row

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Set Rng2 = Wks2.Range(Wks2.Cells(2, 2), Wks2.Cells(LRowWks2, 2))

Columns("AF:AF").ClearContents

With Columns("A:A")
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Name = "Arial"
.Font.Size = 9
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.AddIndent = False
.ShrinkToFit = False
End With

'msgbox added temporarily to show that columns are cleared
MsgBox "Routine ready to run - Click Ok"

'barrowed from member GTO
Dim HACK As Double: HACK = Timer

'**** CODE ABOVE HERE ONLY TAKES ONE SECOND TO RUN,
'****so no need to have screen updating off there.
Application.ScreenUpdating = False

For Each cll In Rng1 '"Sheet1" ColumnB
Set Found = Rng2.Find(What:=cll.Value, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)

boolFound = True

Set FirstFound = Found
Do While boolFound = True
If Not Found Is Nothing Then
With cll
.Offset(0, 30).Value = Found.Offset(0, 30).Value
If UCase(Found.Offset(0, -1).Value) = "P" Then
With .Offset(0, -1)
.Value = "P"
.Font.ColorIndex = 2
.Interior.ColorIndex = 3
End With
End If
End With
Else
boolFound = False
Exit Do
End If

If Found.Address = FirstFound.Address Then Exit Do
Loop

Next

Application.ScreenUpdating = True

Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString


End Sub

frank_m
02-09-2012, 04:28 AM
I discovered that the Do While Loop, BoolFound / FirstFound Exit For's, and Ucase command checking the value "P", all are not necessary.
but some how the code is now running 20% slower.
(Any insight as to why that would be?)

Edit: My bad. I had placed the timer improperly. The truth is that my clean up of the code actually did cause it to run about 20% faster.

Would still like it to be a lot faster than that though.


Private Sub CommandButton1_Click()

Dim Wks1 As Worksheet, Wks2 As Worksheet, Rng1 As Range, Rng2 As Range
Dim cll As Range, LRowWks1 As Long, LRowWks2 As Long, Found As Range

Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")

LRowWks1 = Wks1.Cells(Wks1.Rows.Count, "B").End(xlUp).Row
LRowWks2 = Wks2.Cells(Wks2.Rows.Count, "B").End(xlUp).Row

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Set Rng2 = Wks2.Range(Wks2.Cells(2, 2), Wks2.Cells(LRowWks2, 2))

Columns("AF:AF").ClearContents

With Columns("A:A")
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Name = "Arial"
.Font.Size = 9
.Font.Bold = False
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.AddIndent = False
.ShrinkToFit = False
End With

MsgBox "Previous results have been erased. - Routine is ready to run. - Click ok"

'----TEMP CODE ' barrowed from member GTO
Dim HACK As Double: HACK = Timer
'----END TEMP CODE

Application.ScreenUpdating = False

For Each cll In Rng1 '"Sheet1" ColumnB

Set Found = Rng2.Find(cll.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not Found Is Nothing Then
With cll
.Offset(0, 30).Value = Found.Offset(0, 30).Value
If Found.Offset(0, -1).Value = "P" Then
.Offset(0, -1).Value = "P"
.Offset(0, -1).Font.ColorIndex = 2
.Offset(0, -1).Interior.ColorIndex = 3
End If
End With
End If

Next

Application.ScreenUpdating = True

'----TEMP CODE 'barrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE

End Sub

Bob Phillips
02-09-2012, 04:47 AM
See if this is any better



Private Sub CommandButton1_Click()
Const FORMULA_MATCH As String = _
"=IF(ISNUMBER(MATCH(<cell>,Sheet2!<invoices>,0))," & _
"IF(INDEX(Sheet2!<pmarkers>,MATCH(<cell>,Sheet2!<invoices>,0))=""P"",""P"",""""),"""")"
Dim Wks1 As Worksheet, Wks2 As Worksheet, Rng1 As Range, Rng2 As Range
Dim cll As Range, LRowWks1 As Long, LRowWks2 As Long
Dim nTime As Double

nTime = Timer
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")

LRowWks1 = Wks1.Cells(Wks1.Rows.Count, "B").End(xlUp).Row
LRowWks2 = Wks2.Cells(Wks2.Rows.Count, "B").End(xlUp).Row

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Set Rng2 = Wks2.Range(Wks2.Cells(2, 2), Wks2.Cells(LRowWks2, 2))

Columns("AF:AF").ClearContents

With Columns("A:A")
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Name = "Arial"
.Font.Size = 9
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.AddIndent = False
.ShrinkToFit = False
End With

'msgbox added temporarily to show that columns are cleared
MsgBox "Routine ready to run - Click Ok"

'----TEMP CODE ' barrowed from member GTO
Dim HACK As Double: HACK = Timer
'----END TEMP CODE

Application.ScreenUpdating = False

With Rng1.Cells(1, 1).Offset(-1, -1)

.Value = "Tmp"

Rng1.Offset(0, -1).Formula = Replace(Replace(Replace(FORMULA_MATCH, _
"<cell>", Rng1.Cells(1, 1).Address(False, False)), _
"<invoices>", Rng2.Address), _
"<pmarkers>", Rng2.Offset(0, -1).Address)

.Resize(Rng1.Rows.Count + 1).AutoFilter field:=1, Criteria1:="P"
Set Rng1 = Rng1.SpecialCells(xlCellTypeVisible)
If Not Rng1 Is Nothing Then

With Rng1.Offset(0, -1)

.Value = "P"
.Font.ColorIndex = 2
.Interior.ColorIndex = 3
End With
End If

.AutoFilter

.ClearContents
End With

Application.ScreenUpdating = True

'----TEMP CODE 'barrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE
End Sub

frank_m
02-09-2012, 05:12 AM
HI Bob,

Your code runs 8 to 10 times faster, but it's not filling in the Sh1 Col AF Total value from the Sht2 (Col AF) Total, when a Sht1 Col B match is found in Sht2 Col B.

Hope that's not complicated

Thanks a bunch

Bob Phillips
02-09-2012, 05:33 AM
How can it run any number of times faster when it is running slowly :think:

In my tests, it ran at a fortieth of the time!

Anyway, column AF is already populated, and I can't see your code doing anything there.

frank_m
02-09-2012, 06:06 AM
HI again Bob

You're right, my bad, I accidentally left the Col AF values in Sheet1 when it should be empty. (edit: corrected AD to AF)

I've attached a revised sample. -- So sorry that I accidentally misled you, essentially wasting your time.

My code does fill in the Sht1 Corresponding AF value from Sht2, for every Col B Match. Fortunately there are no duplicate Invoices numbers, but there are some missing.

As for the time, on my machine, my version runs in about 4.8 seconds and yours .6 seconds (8 x .6 = 4.8) 8 times faster, by one way of thinking).
I guess some of us Southern Californian's have a strange way of thinking about things.
Edit: or maybe it's an American slang that I'm not aware of, as here it's common to say that a car traveling at 120 mph, is moving 8 times faster than one that's traveling at only 15 mph. - Or when a heavy object hits the ground in 1 second, we often would describe that as falling 8 times faster than a feather that takes 8 seconds.

As for it taking only a fortieth of the time on your machine, (when the difference is only one eighth of the time on mine), I would guess that might be because I'm on XP with a 6 year old processor and only 500 megs of ram.

Bob Phillips
02-09-2012, 07:09 AM
Option Explicit

Private Sub CommandButton1_Click()
Const FORMULA_MATCH As String = _
"=IF(ISNUMBER(MATCH(<cell>,Sheet2!<invoices>,0))," & _
"IF(INDEX(Sheet2!<pmarkers>,MATCH(<cell>,Sheet2!<invoices>,0))=""P"",""P"",""""),"""")"
Const FORMULA_TOTAL As String = _
"=INDEX(Sheet2!<totals>,MATCH(<cell>,Sheet2!<invoices>,0))"

Dim Wks1 As Worksheet, Wks2 As Worksheet
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim cll As Range, LRowWks1 As Long, LRowWks2 As Long
Dim nTime As Double

nTime = Timer
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")

LRowWks1 = Wks1.Cells(Wks1.Rows.Count, "B").End(xlUp).Row
LRowWks2 = Wks2.Cells(Wks2.Rows.Count, "B").End(xlUp).Row

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Set Rng2 = Wks2.Range(Wks2.Cells(2, 2), Wks2.Cells(LRowWks2, 2))
Set Rng3 = Wks1.Range(Wks1.Cells(2, "AF"), Wks1.Cells(LRowWks1, "AF"))
Set Rng4 = Wks2.Range(Wks2.Cells(2, "AF"), Wks2.Cells(LRowWks2, "AF"))

Columns("AF:AF").ClearContents

With Columns("A:A")
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Name = "Arial"
.Font.Size = 9
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.AddIndent = False
.ShrinkToFit = False
End With

'msgbox added temporarily to show that columns are cleared
MsgBox "Routine ready to run - Click Ok"

'----TEMP CODE ' barrowed from member GTO
Dim HACK As Double: HACK = Timer
'----END TEMP CODE

Application.ScreenUpdating = False
a
Rng3.Formula = Replace(Replace(Replace(FORMULA_TOTAL, _
"<cell>", Rng1.Cells(1, 1).Address(False, False)), _
"<invoices>", Rng2.Address), _
"<totals>", Rng4.Address)
Rng3.Value = Rng3.Value

With Rng1.Cells(1, 1).Offset(-1, -1)

.Value = "Tmp"

Rng1.Offset(0, -1).Formula = Replace(Replace(Replace(FORMULA_MATCH, _
"<cell>", Rng1.Cells(1, 1).Address(False, False)), _
"<invoices>", Rng2.Address), _
"<pmarkers>", Rng2.Offset(0, -1).Address)

.Resize(Rng1.Rows.Count + 1).AutoFilter field:=1, Criteria1:="P"
Set Rng1 = Rng1.SpecialCells(xlCellTypeVisible)
If Not Rng1 Is Nothing Then

With Rng1.Offset(0, -1)

.Value = "P"
.Font.ColorIndex = 2
.Interior.ColorIndex = 3
End With
End If

.AutoFilter

.ClearContents
End With

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Rng1.Offset(0, -1).Value = Rng1.Offset(0, -1).Value

Application.ScreenUpdating = True

'----TEMP CODE 'barrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - HACK, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE
End Sub

frank_m
02-09-2012, 08:21 AM
Hi Bob - once again your the man. - it now does everything I had wished for.

On my old clunker machine it processes in about 2.4 seconds, verses 4.8 for my version.

:bow: Admiration and many thanks being sent your way.

Bob Phillips
02-09-2012, 08:26 AM
I also think it will not increase proportionally as yours would when you go to 20000 rows.

frank_m
02-09-2012, 11:16 PM
Hi Bob,

Could I get you to time the revised attachment? - Here it is taking about 4 minutes to run 19,000 rows, and I'm not able to get into my work place for a couple months to try one of the faster machine's there. - If it's just my slow processor and low ram, then no problem, I'll expedite getting my other pc repaired.

Also I commented out the line .Value = "Tmp", as I don't understand what that would be doing. The code runs at the same time both with or without.
Is my evaluation about that correct ?

With Rng1.Cells(1, 1).Offset(-1, -1)

'.Value = "Tmp"

Rng1.Offset(0, -1).Formula = Replace(Replace(Replace(FORMULA_MATCH, _
"<cell>", Rng1.Cells(1, 1).Address(False, False)), _
"<invoices>", Rng2.Address), _
"<pmarkers>", Rng2.Offset(0, -1).Address)

Thanks

frank_m
02-10-2012, 01:39 AM
I'm not sure which one of these changes helped, but I turned calculation off, then back on afterwards, and set AutomticPageBreaks to False, and that reduced the time from 4 minutes to under 3 minutes.

I'm still curious though how much faster it will run on a good computer, so if you or anyone would try it and let me know the time it takes for you,
I'd appreciate it.

Thanks
Private Sub CommandButton1_Click()
Const FORMULA_MATCH As String = _
"=IF(ISNUMBER(MATCH(<cell>,Sheet2!<invoices>,0))," & _
"IF(INDEX(Sheet2!<pmarkers>,MATCH(<cell>,Sheet2!<invoices>,0))=""P"",""P"",""""),"""")"
Const FORMULA_TOTAL As String = _
"=INDEX(Sheet2!<totals>,MATCH(<cell>,Sheet2!<invoices>,0))"

Dim Wks1 As Worksheet, Wks2 As Worksheet
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim cll As Range, LRowWks1 As Long, LRowWks2 As Long
Dim nTime As Double

nTime = Timer
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")

LRowWks1 = Wks1.Cells(Wks1.Rows.Count, "B").End(xlUp).Row
LRowWks2 = Wks2.Cells(Wks2.Rows.Count, "B").End(xlUp).Row

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Set Rng2 = Wks2.Range(Wks2.Cells(2, 2), Wks2.Cells(LRowWks2, 2))
Set Rng3 = Wks1.Range(Wks1.Cells(2, "AF"), Wks1.Cells(LRowWks1, "AF"))
Set Rng4 = Wks2.Range(Wks2.Cells(2, "AF"), Wks2.Cells(LRowWks2, "AF"))

Columns("AF:AF").ClearContents

Range("AF1").Value = "Total"

With Columns("A:A")
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Name = "Arial"
.Font.Size = 9
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.AddIndent = False
.ShrinkToFit = False
End With

'msgbox added temporarily to show that columns are cleared
MsgBox "Routine ready to run - Click Ok"


With ActiveSheet
.DisplayAutomaticPageBreaks = False
.EnableCalculation = False
End With

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


Rng3.Formula = Replace(Replace(Replace(FORMULA_TOTAL, _
"<cell>", Rng1.Cells(1, 1).Address(False, False)), _
"<invoices>", Rng2.Address), _
"<totals>", Rng4.Address)
Rng3.Value = Rng3.Value

With Rng1.Cells(1, 1).Offset(-1, -1)

'I left the next line in, but if you would explain the reason for it, I appreciate it.
.Value = "Tmp"

Rng1.Offset(0, -1).Formula = Replace(Replace(Replace(FORMULA_MATCH, _
"<cell>", Rng1.Cells(1, 1).Address(False, False)), _
"<invoices>", Rng2.Address), _
"<pmarkers>", Rng2.Offset(0, -1).Address)

.Resize(Rng1.Rows.Count + 1).AutoFilter field:=1, Criteria1:="P"
Set Rng1 = Rng1.SpecialCells(xlCellTypeVisible)
If Not Rng1 Is Nothing Then

With Rng1.Offset(0, -1)

.Value = "P"
.Font.ColorIndex = 2
.Interior.ColorIndex = 3
End With
End If

.AutoFilter

.ClearContents
End With

Set Rng1 = Wks1.Range(Wks1.Cells(2, 2), Wks1.Cells(LRowWks1, 2))
Rng1.Offset(0, -1).Value = Rng1.Offset(0, -1).Value

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

With ActiveSheet
.EnableCalculation = True
.Calculate
End With

'----TEMP CODE 'borrowed from member GTO
Dim TmpString As String
TmpString = "Time is second: " & _
FormatNumber(Timer - nTime, 3, vbTrue, vbTrue, vbFalse) & " seconds."
'Debug.Print TmpString
MsgBox TmpString
'----END TEMP CODE
End Sub Revised sample file attachmed

Bob Phillips
02-10-2012, 03:04 AM
Also I commented out the line .Value = "Tmp", as I don't understand what that would be doing. The code runs at the same time both with or without.
Is my evaluation about that correct ?

When I create a filter I am usually deleting rows so I always add a heading to filter from that point and ensure that the first row gets considered as a data row in the filter, not the heading. You could have a problem with the first row and for what it costs in the performance, it is not worth ot doing.

Bob Phillips
02-10-2012, 03:04 AM
I just ran it on my Netbook Frank. Not the fastest machine in the world, but not a bad little box, and it took 69 seconds (the version in #11).

Bob Phillips
02-10-2012, 03:32 AM
Oddly, the second version took 71 seconds.

I broke the timings down, and as expected the time is all in setting the formulae, 69 seconds of the 71. The first takes 24 seconds, the second 45. Difficult to see where that can be reduced.

frank_m
02-10-2012, 09:03 AM
I just ran it on my Netbook Frank. Not the fastest machine in the world, but not a bad little box, and it took 69 seconds (the version in #11).

Difficult to see where that can be reduced.
69 seconds is fine. - I'm now more motivated to get my other machine repaired.
Thanks for checking that, and for the explanation about the "tmp" heading, and the timing break down.



Oddly, the second version took 71 seconds.
Yeah that is odd. - I'll make a code comment to myself so I'll be aware of that later. - Thanks for trying both.