VLookup simulation: copying data from one sheet to another

Question

I tried to write a VLOOKUP in my macro but for some unknown reasons it didn't work (see my post on StackOverFlow for more info.

So I decided to do a macro which achieves the same result, but it takes about 20 sec to run. Any ideas on how I can improve its performance ?

What this macro is doing :

I have 2 worksheets in my workbook. Both have a column listing VINs + other info. What this macro is doing is a Vlookup from one sheet to the other one to retrieve some information when the same VIN is found.

Sub ReplacementVlookups()
'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)
Worksheets("All Time SMS Dump").Columns("G:G").NumberFormat = "General"
Worksheets("All Time SMS Dump").Columns("H:H").NumberFormat = "General"
'Store all Lookup values in a 1D array
Dim VLookupType As Integer
Dim j As Integer
Dim LastRow As Integer
Dim LastRowSF As Integer
Dim VINArrayAllTime As Variant
Dim VINArraySF As Variant
Dim ValuesCopied As Variant
Dim ValuesPasted As Variant
LastRow = Worksheets("All Time SMS Dump").Range("A" & Rows.Count).End(xlUp).Row
LastRowSF = Worksheets("Salesforce Dump").Range("A" & Rows.Count).End(xlUp).Row
VINArrayAllTime = Worksheets("All Time SMS Dump").Range("A2:A" & LastRow)
VINArraySF = Worksheets("Salesforce Dump").Range("C2:C" & LastRowSF)
For VLookupType = 1 To 3 ' I have 3 columns on which I want to apply the VLookup
 If VLookupType = 1 Then
 ValuesCopied = Worksheets("Salesforce Dump").Range("D2:D" & LastRowSF)
 ValuesPasted = Worksheets("All Time SMS Dump").Range("G2:G" & LastRow)
 'Do a VLOOKUP
 For i = 2 To LastRow
 For j = 2 To LastRowSF - 1
 If VINArrayAllTime(i - 1, 1) = VINArraySF(j - 1, 1) Then
 ValuesPasted(i - 1, 1) = ValuesCopied(j - 1, 1)
 Exit For
 End If
 Next j
 Next i
 Worksheets("All Time SMS Dump").Range("G2:G" & LastRow) = ValuesPasted
 ElseIf VLookupType = 2 Then
 ValuesCopied = Worksheets("Salesforce Dump").Range("E2:E" & LastRowSF)
 ValuesPasted = Worksheets("All Time SMS Dump").Range("H2:H" & LastRow)
 'Do a VLOOKUP
 For i = 2 To LastRow
 For j = 2 To LastRowSF - 1
 If VINArrayAllTime(i - 1, 1) = VINArraySF(j - 1, 1) Then
 ValuesPasted(i - 1, 1) = ValuesCopied(j - 1, 1)
 Exit For
 End If
 Next j
 Next i
 Worksheets("All Time SMS Dump").Range("H2:H" & LastRow) = ValuesPasted
 Else:
 ValuesCopied = Worksheets("Salesforce Dump").Range("F2:F" & LastRowSF)
 ValuesPasted = Worksheets("All Time SMS Dump").Range("I2:I" & LastRow)
 'Do a VLOOKUP
 For i = 2 To LastRow
 For j = 2 To LastRowSF - 1
 If VINArrayAllTime(i - 1, 1) = VINArraySF(j - 1, 1) Then
 ValuesPasted(i - 1, 1) = ValuesCopied(j - 1, 1)
 Exit For
 End If
 Next j
 Next i
 Worksheets("All Time SMS Dump").Range("I2:I" & LastRow) = ValuesPasted
 End If
Next VLookupType
End Sub

• PeterT: You're already using memory arrays, so you already have most of any potential speed up there. How many rows are you typically searching?

Answer 1

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)

• steenbergh: I like the way this answer whittles down the problem.