Hi,
I have two sheets (Header & Item) in one file. Header has 25k and Item 50k rows. I'm looping through col B in Header and looking values in col B in Item and when we have a match then copying some values from Header-sheet to Item-sheet. I want this to be as fast as possible.
I have two different macros to do this, both doing what I want and working basically fine. One uses arrays and the other one not. I read about arrays and thought that they should make this faster but the results are quite contrary. Array macro takes 336 seconds and the other one 42 seconds to accomplish.
Is there something terribly wrong with my array macro or why is it so slow...? If there are any other comments or best practises concerning these macros, I would be glad to hear them. Thanks!
Sub test_array()
Dim i As Long
Dim Header_dummy As Variant, Item_dummy As Variant, Ws1 As Worksheet, Ws2 As Worksheet
Dim LRow As Long, x As Long, targetArr As Variant, sourceArr As Variant
Dim startT As Double, endT As Double
Application.ScreenUpdating = False
startT = Timer
Set Ws1 = Sheets("Header")
Set Ws2 = Sheets("Item")
'declare arrays
LRow = Ws1.Cells(Application.Rows.Count, 2).End(xlUp).Row
Header_dummy = Ws1.Range("B3:B" & LRow).Value2
sourceArr = Ws1.Range("F3:H" & LRow).Value2
LRow = Ws2.Cells(Application.Rows.Count, 2).End(xlUp).Row
Item_dummy = Ws2.Range("B3:B" & LRow).Value2
targetArr = Ws2.Range("T3:V" & LRow).Value2
For i = 1 To UBound(Header_dummy)
'first match
On Error Resume Next
x = Application.WorksheetFunction.Match(Header_dummy(i, 1), Item_dummy, 0)
On Error GoTo 0
If x <> 0 Then
'copy values to target array
targetArr(x, 1) = sourceArr(i, 1)
targetArr(x, 2) = sourceArr(i, 2)
targetArr(x, 3) = sourceArr(i, 3)
End If
x = 0
Next i
'copy array to item sheet
Ws2.Range("T3:V" & LRow) = targetArr
endT = Timer
Application.ScreenUpdating = True
MsgBox endT - startT
End Sub
And the other macro as well:
Sub Fill_in_item()
Dim Ws5 As Worksheet, Ws4 As Worksheet
Dim LRowWs4 As Long, LRowWs5 As Long
Dim rowId As Range, i As Long, MatchRow As Long
Dim startT As Double, endT As Double
Application.ScreenUpdating = False
startT = Timer
Set Ws4 = Sheets("Header")
Set Ws5 = Sheets("Item")
Ws5.Activate
LRowWs4 = Ws4.Cells(Application.Rows.Count, 2).End(xlUp).Row
LRowWs5 = Ws5.Cells(Application.Rows.Count, 2).End(xlUp).Row
Set rowId = Range(Ws5.Cells(1, 2), Ws5.Cells(LRowWs5, 2))
'Debug.Print rowId.Address
For i = 3 To LRowWs4
'find match & copy values
MatchRow = WorksheetFunction.Match(Ws4.Cells(i, 2), rowId, 0)
Range(Ws5.Cells(MatchRow, 20), Ws5.Cells(MatchRow, 22)).Value = Range(Ws4.Cells(i, 6), Ws4.Cells(i, 8)).Value
Next
endT = Timer
MsgBox endT - startT
Application.ScreenUpdating = True
End Sub
Bookmarks