This was an interesting challenge - improve performance of arrays
But first, to cover the basics:
- Option Explicit is missing - this statement fixes the most basic syntax issues
- The range references are good overall, but lengthy and repetitive
- The only one missing is on the 6th line
Rows(... which deletes rows from active sheet
- Indentation is inconsistent, and missing at the first level (
Sub - End Sub) - The first loop doesn't work properly, and every execution it deletes the last row with data
- For 10 rows
i=11, but the .End(xlUp).Row is 10, and becomes Rows("11:10").Delete
'Delete Rows with no content Dim i As Integer i = 0 Do i = i + 1 Loop While Range("A" & i) <> "" Rows(i & ":" & Worksheets("All Time SMS Dump").Range("A" & Rows.Count).End(xlUp).Row).Delete (xlShiftUp)
- In all For loops you have
For i = 2 To... & For j = 2 To... then compare i - 1 = j - 1 - Assigning
.Range("D2:D" & LastRowSF) to array, first item in the array is D2 (index 1)
- The main Sub defaults to public, but the
Public keyword should be explicit - Most subs and functions should be made
Private to modules unless they are utilities
On to Performance
I'm providing 3 versions for comparison (v1 - is your version with three For loops)
- v2 - Code cleanup and optimization (three For loops)
- v3 - Improve performance - change algorithm (one For loop)
- v4 - Arrays and a dictionary (one For loop)
v2 - Code cleanup and optimization (three For loops)
Public Sub VinLookUpArr1() Dim wsAT As Worksheet, wsSF As Worksheet, valAT As Variant, valSF As Variant Dim lrAT As Long, lrSF As Long, vinAT As Variant, vinSF As Variant, t As Double t = Timer Set wsAT = ThisWorkbook.Worksheets("All Time SMS Dump") Set wsSF = ThisWorkbook.Worksheets("Salesforce Dump") lrAT = wsAT.Range("A" & Rows.Count).End(xlUp).Row lrSF = wsSF.Range("A" & Rows.Count).End(xlUp).Row vinAT = wsAT.Range("A2:A" & lrAT) vinSF = wsSF.Range("C2:C" & lrSF) wsAT.Rows(wsAT.Rows(1).End(xlDown).Row + 1 & ":" & lrAT + 1).Delete xlShiftUp wsSF.Rows(wsSF.Rows(1).End(xlDown).Row + 1 & ":" & lrSF + 1).Delete xlShiftUp wsAT.Columns("G:H").NumberFormat = "General" valAT = wsAT.Range("G2:G" & lrAT) valSF = wsSF.Range("D2:D" & lrSF) wsAT.Range("G2:G" & lrAT) = DoLookUpArr1(vinAT, vinSF, valAT, valSF) valAT = wsAT.Range("H2:H" & lrAT) valSF = wsSF.Range("E2:E" & lrSF) wsAT.Range("H2:H" & lrAT) = DoLookUpArr1(vinAT, vinSF, valAT, valSF) valAT = wsAT.Range("I2:I" & lrAT) valSF = wsSF.Range("F2:F" & lrSF) wsAT.Range("I2:I" & lrAT) = DoLookUpArr1(vinAT, vinSF, valAT, valSF) Debug.Print "lrAT: " & lrAT & "; lrSF: " & lrSF & "; Time: " & Format(Timer - t, "0.000") End Sub
Private Function DoLookUpArr1(ByVal vinAT As Variant, ByVal vinSF As Variant, _ ByVal valAT As Variant, ByVal valSF As Variant) As Variant Dim rAT As Long, rSF As Long, lrSF As Long lrSF = UBound(valSF) For rAT = 1 To UBound(valAT) For rSF = 1 To lrSF If vinAT(rAT, 1) = vinSF(rSF, 1) Then valAT(rAT, 1) = valSF(rSF, 1) Exit For End If Next rSF Next rAT DoLookUpArr1 = valAT End Function
v3 - Improve performance - change algorithm (one For loop)
- This loops only once for all vLookups:
Public Sub VinLookUpArr2() Dim wsAT As Worksheet, wsSF As Worksheet, urAT As Variant, urSF As Variant Dim lrAT As Long, lrSF As Long, lcAT As Long, lcSF As Long, t As Double Dim rAT As Long, rSF As Long, map(1 To 2, 1 To 4) As Byte, i As Long t = Timer Set wsAT = ThisWorkbook.Worksheets("All Time SMS Dump") Set wsSF = ThisWorkbook.Worksheets("Salesforce Dump") map(1, 1) = 1: map(2, 1) = 3 'A to C (VINs) map(1, 2) = 7: map(2, 2) = 4 'G to D map(1, 3) = 8: map(2, 3) = 5 'H to E map(1, 4) = 9: map(2, 4) = 6 'I to F lrAT = wsAT.Cells(Rows.Count, 1).End(xlUp).Row 'lr = last row lrSF = wsSF.Cells(Rows.Count, 1).End(xlUp).Row lcAT = wsAT.Cells(1, Columns.Count).End(xlToLeft).Column 'lc = last col lcSF = wsSF.Cells(1, Columns.Count).End(xlToLeft).Column urAT = wsAT.Range(wsAT.Cells(1), wsAT.Cells(lrAT, lcAT)) 'ur = used range urSF = wsSF.Range(wsSF.Cells(1), wsSF.Cells(lrSF, lcSF)) For rAT = 2 To lrAT For rSF = 2 To lrSF If urAT(rAT, map(1, 1)) = urSF(rSF, map(2, 1)) Then For i = 2 To 4 urAT(rAT, map(1, i)) = urSF(rSF, map(2, i)) Next Exit For End If Next Next wsAT.Range(wsAT.Cells(1), wsAT.Cells(lrAT, lcAT)) = urAT Debug.Print "lrAT: " & lrAT & "; lrSF: " & lrSF & "; Time: " & Format(Timer - t, "0.000") End Sub
v4 - Arrays and a dictionary (one For loop)
- The most important improvement is gained by the
.Exists() method of the dictionary
Public Sub VinLookUpDictionary() Dim wsAT As Worksheet, wsSF As Worksheet, urAT As Variant, urSF As Variant Dim lrAT As Long, lrSF As Long, lcAT As Long, lcSF As Long, t As Double Dim rAT As Long, rSF As Long, map(1 To 2, 1 To 4) As Byte, i As Long, d As Dictionary t = Timer Set d = New Dictionary Set wsAT = ThisWorkbook.Worksheets("All Time SMS Dump") Set wsSF = ThisWorkbook.Worksheets("Salesforce Dump") map(1, 1) = 1: map(2, 1) = 3 'A to C (VINs) map(1, 2) = 7: map(2, 2) = 4 'G to D map(1, 3) = 8: map(2, 3) = 5 'H to E map(1, 4) = 9: map(2, 4) = 6 'I to F lrAT = wsAT.Cells(Rows.Count, 1).End(xlUp).Row 'lr = last row lrSF = wsSF.Cells(Rows.Count, 1).End(xlUp).Row lcAT = wsAT.Cells(1, Columns.Count).End(xlToLeft).Column 'lc = last col lcSF = wsSF.Cells(1, Columns.Count).End(xlToLeft).Column urAT = wsAT.Range(wsAT.Cells(1), wsAT.Cells(lrAT, lcAT)) 'ur = used range urSF = wsSF.Range(wsSF.Cells(1), wsSF.Cells(lrSF, lcSF)) For rSF = 2 To lrSF d(urSF(rSF, map(2, 1))) = vbNullString Next For rAT = 2 To lrAT For rSF = 2 To lrSF If d.Exists(urAT(rAT, map(1, 1))) Then For i = 2 To 4 urAT(rAT, map(1, i)) = urSF(rSF, map(2, i)) Next Exit For End If Next Next wsAT.Range(wsAT.Cells(1), wsAT.Cells(lrAT, lcAT)) = urAT Debug.Print "lrAT: " & lrAT & "; lrSF: " & lrSF & "; Time: " & Format(Timer - t, "0.000") End Sub
Results
Total Rows on sheet "All Time SMS Dump": 20,001 Total Rows on sheet "Salesforce Dump": 20,001
v1 = Time: 53.469 sec (arrays - 3 loops) v2 = Time: 54.676 sec (arrays - 3 loops) v3 = Time: 20.637 sec (arrays - 1 loop) v4 = Time: 0.484 sec (arrays & dictionary - 1 loop)
