PDA

View Full Version : [SOLVED] Speed up Macro



framcc06
09-30-2018, 10:07 AM
Hi Folks,

Still fairly new to VBA, I am currently using the below code to compare Column A between Sheet1 and Sheet2 then bring in the value of Column B in Sheet2 into Column B of Sheet1.

This is great when working with low row numbers, however, I'm now working on a file with 10000+ rows and the macro is taking very long to process.

Current code;


Option Explicit
Sub GetValues()
Application.ScreenUpdating = False


Dim i As Long, j As Long
Sheet1LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

For j = 1 To Sheet1LastRow
For i = 1 To Sheet2LastRow

If Worksheets("Sheet1").Cells(j, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value Then
Worksheets("Sheet1").Cells(j, 2).Value = wb.Worksheets("Sheet1").Cells(i, 2).Value
End If
Next i
Next j


End Sub


Would anyone have a more efficient way of doing this to speed up the processing time?

Many Thanks

Fra

p45cal
09-30-2018, 10:45 AM
…but it's not your current code, is it? No mention of Sheet2 at all!
Try:
Sub GetValues2()
Sheet1LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1").Range("B1:B" & Sheet1LastRow)
.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet2!R1C1:R" & Sheet2LastRow & "C2,2,FALSE)"
.SpecialCells(xlCellTypeFormulas, 16).ClearContents
.Value = .Value
End With
End Sub
If it's still too slow then we can try again.
Perhaps:
Sub GetValues3()
Set rng1 = Range(Worksheets("Sheet1").Range("A1"), Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
Set rng2 = Range(Worksheets("Sheet2").Range("A1"), Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
cc = Application.VLookup(rng1, rng2, 2, False)
For i = 1 To UBound(cc)
If IsError(cc(i, 1)) Then cc(i, 1) = Empty
Next i
rng1.Offset(, 1).Value = cc
End Sub

Fluff
09-30-2018, 11:47 AM
Another option
Sub LookupCopy()
Dim InAry As Variant, Oary As Variant
Dim i As Long

With Sheets("sheet1")
InAry = .Range("A1", .Range("A" & Rows.Count).End(xlUp).Offset(, 1))
End With
With Sheets("sheet2")
Oary = .Range("A1", .Range("A" & Rows.Count).End(xlUp).Offset(, 1))
End With
With CreateObject("scripting.dictionary")
For i = 1 To UBound(InAry)
.Item(InAry(i, 1)) = InAry(i, 2)
Next i
For i = 1 To UBound(Oary)
Oary(i, 2) = .Item(Oary(i, 1))
Next i
End With
Sheets("sheet2").Range("B1").Resize(UBound(Oary)).Value = Application.Index(Oary, 0, 2)
End Sub

Paul_Hossler
09-30-2018, 12:06 PM
Try this

Looping is slow, nested loops are really slow, and if the loops access worksheets repeatedly, it's REALLY slow




Option Explicit


Sub TEST()
Dim r1 As Range, r2 As Range
Dim ary12 As Variant, ary22 As Variant, ary1 As Variant, ary2 As Variant
Dim i As Long, m As Long

Set r1 = Worksheets("sheet1").Cells(1, 1).CurrentRegion.Resize(, 2)
Set r2 = Worksheets("sheet2").Cells(1, 1).CurrentRegion

ary12 = r1.Value
ary22 = r2.Value

ary1 = Application.WorksheetFunction.Transpose(r1.Columns(1))
ary2 = Application.WorksheetFunction.Transpose(r2.Columns(1))


For i = LBound(ary1) To UBound(ary1)
m = 0
On Error Resume Next
m = Application.WorksheetFunction.Match(ary1(i), ary2, 0)
On Error Resume Next

If m > 0 Then
ary12(i, 2) = ary22(m, 2)
End If
Next i

r1.Value = ary12
End Sub

framcc06
09-30-2018, 12:28 PM
Many Thanks for the replies, both methods have certainly speeded things up!

p45cal one more question, just say I wanted to get the values of column D from Sheet2 into Column D of Sheet1 by comparing Column A how would I modify below code to make it work?


Sub GetValues3()Set rng1 = Range(Worksheets("Sheet1").Range("A1"), Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
Set rng2 = Range(Worksheets("Sheet2").Range("A1"), Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
cc = Application.VLookup(rng1, rng2, 2, False)
For i = 1 To UBound(cc)
If IsError(cc(i, 1)) Then cc(i, 1) = Empty
Next i
rng1.Offset(, 1).Value = cc
End Sub


Thanks Again

Fra

p45cal
09-30-2018, 01:16 PM
just say I wanted to get the values of column D from Sheet2 into Column D of Sheet1 by comparing Column A how would I modify below code to make it work?untested:
Sub GetValues3()
Set rng1 = Range(Worksheets("Sheet1").Range("A1"), Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
Set rng2 = Range(Worksheets("Sheet2").Range("A1"), Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Resize(, 4)
cc = Application.VLookup(rng1, rng2, 4, False)
For i = 1 To UBound(cc)
If IsError(cc(i, 1)) Then cc(i, 1) = Empty
Next i
rng1.Offset(, 3).Value = cc
End Sub

framcc06
09-30-2018, 01:48 PM
Thanks p45cal, it worked perfectly.

I'm marking this thread as solved.

Thanks again

Fra

p45cal
09-30-2018, 01:55 PM
Since this thread's subject is "Speed up Macro", what kind of speed increase did you obtain?
Did you compare others' solutions for speed?

framcc06
09-30-2018, 02:12 PM
Sorry, the code I used from the first post was around 40 minutes, your generous solution done it in a matter of seconds.

Fra

p45cal
10-01-2018, 04:42 AM
Speed test results on 10,000 unique, randomly sorted values on sheet1 and 2000 unique randomly sorted rows of lookup table on sheet2. The GetValues sub took 230 seconds on my machine.
GetValues 1
TEST 50
GetValues2 400
GetValues3 412
LookupCopy 5230

So Fluff's LookupCopy is streaks ahead (13 times quicker than my faster offering) although it needed tweaking to match the lookup table being on sheet2 and the results being placed on Sheet1:

Sub LookupCopy()
Dim InAry As Variant, Oary As Variant
Dim i As Long

With Sheets("sheet1")
Oary = .Range("A1", .Range("A" & Rows.Count).End(xlUp).Offset(, 1))
End With
With Sheets("sheet2")
InAry = .Range("A1", .Range("A" & Rows.Count).End(xlUp).Offset(, 1))
End With
Set dic = CreateObject("scripting.dictionary")
With dic
For i = 1 To UBound(InAry)
.Item(InAry(i, 1)) = InAry(i, 2)
Next i
For i = 1 To UBound(Oary)
Oary(i, 2) = .Item(Oary(i, 1))
Next i
End With
Sheets("sheet1").Range("B1").Resize(UBound(Oary)).Value = Application.Index(Oary, 0, 2)
End Sub

Paul_Hossler
10-01-2018, 07:23 AM
@p45cal --

I'm curious -- I like to use the Match technique in my #4 for lots of different things (but I'm willing to learn others)

Could you use that macro with your test data and let me know the relative performance?

Thanks

framcc06
10-01-2018, 07:58 AM
p45cal last question on your GetValues3 code.

If i wanted to get the values from Column A from Sheet2 into Column D of Sheet1 by comparing values of Column B of Sheet1 and Sheet2 would I need to use offset somewhere in the rng2 worksheet name?

Thanks

Fra

p45cal
10-01-2018, 08:41 AM
Could you use that macro with your test data and let me know the relative performance?It's there in msg#10, under TEST. (50 times faster than GetValues which has a performance of 1. All the macros are rated using GetValues as a base, so LookupCopy is 5230 times faster than GetValues.)
22961
(The GetValues No Exit For is the OP's original macro, the GetValues Exit For is a version of it where I added an Exit For line within the inner loop to stop searching if a match was found)

p45cal
10-01-2018, 08:52 AM
If i wanted to get the values from Column A from Sheet2 into Column D of Sheet1 by comparing values of Column B of Sheet1 and Sheet2 would I need to use offset somewhere in the rng2 worksheet name?
I'm confused. Sheet1 doesn't have any values in column B until after one of the macros is run. So could you supply a workbook to clarify what you're wanting?

Paul_Hossler
10-01-2018, 10:11 AM
It's there in msg#10, under TEST. (50 times faster than GetValues which has a performance of 1. All the macros are rated using GetValues as a base, so LookupCopy is 5230 times faster than GetValues.)


Sorry - I missed that

I'm amazed that using a Dictionary is ~100x faster than using arrays and built-in functions (e.g. TEST)

I'd have thought that building the dictionary and looking up indexes would have added more overhead

framcc06
10-01-2018, 10:13 AM
p45cal sorry for the confusion, I have attached 2 sample files test1 & test2.

test1 has Fluff's LookupCopy code (thanks Fluff btw), now, how would I modify it on the test2 file where I want to compare Column B in both sheets, then import the values from Column A in sheet 1 into Column D of sheet2.

Thanks Again

Fra

Fluff
10-01-2018, 10:59 AM
There are no values in col A on sheet1 & even if there were the sheet1 col A heading is different to the sheet2 col D heading

p45cal
10-01-2018, 11:13 AM
I'm amazed that using a Dictionary is ~100x faster than using arrays and built-in functions (e.g. TEST)
I'd have thought that building the dictionary and looking up indexes would have added more overhead
See if I've done anything wrong in the attached.
Stuff gets put in the Immediate pane of the VBE which can be copy/pasted to a sheet and a pivot table created.

framcc06, I won't be able to do anything until tomorrow afternoon (UK time).

framcc06
10-01-2018, 11:42 AM
Oops! I got the sheets mixed up should be... compare Column B in both sheets, then import the values from Column A in sheet2 into Column D of sheet1. I also didn't think the heading names would matter.

Fra

Fluff
10-01-2018, 12:01 PM
Try
Sub LookupCopy()
Dim InAry As Variant, Oary As Variant
Dim i As Long

With Sheets("sheet2")
InAry = .Range("A2", .Range("B" & Rows.Count).End(xlUp))
End With
With Sheets("sheet1")
Oary = .Range("B2", .Range("B" & Rows.Count).End(xlUp).Offset(, 2))
End With
With CreateObject("scripting.dictionary")
For i = 1 To UBound(InAry)
.Item(InAry(i, 2)) = InAry(i, 1)
Next i
For i = 1 To UBound(Oary)
Oary(i, 3) = .Item(Oary(i, 1))
Next i
End With
Sheets("sheet1").Range("d2").Resize(UBound(Oary)).Value = Application.Index(Oary, 0, 3)
End Sub

p45cal
10-02-2018, 10:41 AM
how would I modify it on the test2 file where I want to compare Column B in both sheets, then import the values from Column A in sheet 1 into Column D of sheet2.VLookUp is designed to look up a vaue in the leftmost column of a range and return the value in one of the columns to the right of it. In this case it's easier to use Index/Match (Vlookup can be used to lookup to the left but it's convoluted to do so and I've never made it work in vba, only on a sheet). This code is designed to work on your Test2.xlsm file:
Sub GetValues5()
Set rng1 = Range(Worksheets("Sheet1").Range("B2"), Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Set rng2a = Range(Worksheets("Sheet2").Range("B2"), Worksheets("Sheet2").Range("B" & Rows.Count).End(xlUp))
Set rng2b = rng2a.Offset(, -1)
'---------------------------
'either:
cc = Application.Index(rng2b, Application.Match(rng1, rng2a, 0))

'or (if you've got more than 1 column to process you can use the same index):
'dd = Application.Match(rng1, rng2a, 0)
'cc = Application.Index(rng2b, dd)
'---------------------------
For i = 1 To UBound(cc)
If IsError(cc(i, 1)) Then cc(i, 1) = Empty
Next i
rng1.Offset(, 2).Value = cc
End Sub

p45cal
10-02-2018, 10:54 AM
I'd have thought that building the dictionary and looking up indexes would have added more overheadPaul, I agree, one would expect that, but I've long since expected the unexpected with Excel and often test something like this to try to confirm the expected. [Actually, this isn't confined to Excel, but to life in general; so many times people (politicians included/especially) make a statement which they try and make out is blinking obvious, but when you dig deeper you find it's not so obvious, and is often downright wrong. People call me cynical, but I won't change as this sort of thing happens only too often]
Anyway, did you look at my testing file in msg#18 and get similar results?

Fluff
10-02-2018, 12:06 PM
I got similar times although I was getting times of ~7.8 for TEST.
But with this version I was getting ~6.4
Sub TEST()
Dim r1 As Range, r2 As Range
Dim ary12 As Variant, ary22 As Variant, ary1 As Variant, ary2 As Variant
Dim i As Long, m As Long
StartTime = Timer

Set r1 = Worksheets("sheet1").Cells(1, 1).CurrentRegion.Resize(, 2)
Set r2 = Worksheets("sheet2").Cells(1, 1).CurrentRegion

ary12 = r1.Value
ary22 = r2.Value
'
'ary1 = Application.WorksheetFunction.Transpose(r1.Columns(1))
'ary2 = Application.WorksheetFunction.Transpose(r2.Columns(1))


For i = LBound(ary12) To UBound(ary12)
For j = LBound(ary22) To UBound(ary22)
If ary12(i, 1) = ary22(j, 1) Then
ary12(i, 2) = ary22(j, 2)
Exit For
End If
Next j
Next i
Debug.Print "TEST" & vbTab & Timer - StartTime
Sheet1.Range("B1").Resize(UBound(ary12)).Value = Application.Index(ary12, 0, 2)
'r1.Value = ary12 'commented out because I didn't want possibly to mess column A
End SubNested loops through arrays seems faster than using Application.Match

framcc06
10-02-2018, 02:56 PM
Thanks p45cal, I did think I needed to use Offset somewhere but just didn't know where to stick it in the code.

Once again thanks to everyone who have helped with their suggestions.

Fra