VLookup simulation: copying data from one sheet to another

By Posted on

Problem

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

Solution

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)

Leave a Reply

Your email address will not be published. Required fields are marked *