VBA Vlookup to work faster

Question

I have a code in vba that works well but it is slow so I am looking for a better solution to this code.

If there is any one who could help me I would be grateful!

Sub Formula()


Sheets("Result").Range("D2:D" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-2],DATA!C[2]:C[86],3,FALSE)" 

Sheets("Result").Range("E2:E" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-3],DATA'!C[1]:C[85],4,FALSE)" 

Sheets("Result").Range("F2:F" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-4],DATA!C:C[84],13,FALSE)" 

Sheets("Result").Range("G2:G" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-5],DATA!C[-5]:C,6,FALSE)" 

Sheets("Result").Range("H2:H" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-6],DATA!C[-2]:C[82],21,FALSE)" 

Sheets("Result").Range("I2:I" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-7],DATA!C[-3]:C[81],22,FALSE)" 

Sheets("Result").Range("J2:J" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-8],DATA!C[-4]:C[80],24,FALSE)" 

Sheets("Result").Range("K2:K" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-9],DATA!C[-5]:C[79],25,FALSE)" 

Sheets("Result").Range("L2:L" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-10],DATA!C[-6]:C[78],44,FALSE)" 

Dim LastRowColumnA As Long
LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Result").Range("A2:L" & LastRowColumnA).Select
Selection.Copy
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

Answer 1

This should run faster. If any of the applications I turn off at the start is messing up with the functionality of the macro delete it.

Sub Formula()

'turn off applications not required
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Activesheet.DisplayPageBreaks = False

With Sheets("Result")

.Range("D2:D" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-2],DATA!C[2]:C[86],3,FALSE)" 
.Range("E2:E" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-3],DATA'!C[1]:C[85],4,FALSE)" 
.Range("F2:F" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-4],DATA!C:C[84],13,FALSE)" 
.Range("G2:G" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-5],DATA!C[-5]:C,6,FALSE)" 
.Range("H2:H" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-6],DATA!C[-2]:C[82],21,FALSE)" 
.Range("I2:I" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-7],DATA!C[-3]:C[81],22,FALSE)" 
.Range("J2:J" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-8],DATA!C[-4]:C[80],24,FALSE)" 
.Range("K2:K" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-9],DATA!C[-5]:C[79],25,FALSE)" 
.Range("L2:L" & Cells(Rows.Count, 2).End(xlUp).Row).FormulaR1C1 = "=VLOOKUP(RC[-10],DATA!C[-6]:C[78],44,FALSE)" 

End With

Dim LastRowColumnA As Long
LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Result").Range("A2:L" & LastRowColumnA).Select
Selection.Copy
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'turn applications back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Activesheet.DisplayPageBreaks = True

End Sub

Answer 2

Suggestion: use named ranges if possible to make your ranges more descriptive (and also diminish the risk of confusion).

And perhaps try the UsedRange argument rather than selecting whole columns down to the last row. The overly broad selection is wasteful and could be a cause of slowdown. I am on Linux now, so I can't test. But make sure you are not making calculations for nothing. Focus on the range that is effectively in use and holding data, not the whole sheet.

Something else: the relative references. For example:

VLOOKUP(RC[-3],

means if I am not wrong: the current row and 3 columns to the left. I am wondering if this could be faster if written in plain A1 notation instead, so Excel doesn't have to compute the value. This is a question, I really don't know but it's something I might want to try.

Answer 3

A VBA Lookup

• The two 'Source Lookup Ranges' ("F2:Flr", "B2:Blr"), the ranges where you try to find a match, stay as ranges (because Application.Match is faster on ranges) while the rest is written to arrays. The results are written to the 'Destination Array' (dData) which is then, in one go, written to the 'Destination Range'.

• Adjust (double-check) the values in the constants section.

Option Explicit

Sub VBALookup()
    
    Const sName As String = "Data"
    Const slFirst1 As String = "F2"
    Const slFirst2 As String = "B2"
    Const sl2ColIndex As Long = 3 ' in connection to "B2" and ...,G,...
    Const sColsList As String = "H,I,R,G,Z,AA,AC,AD,AW"
    
    Const dName As String = "Result"
    Const dlFirst As String = "B2"
    Const dFirst As String = "D2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlrg As Range: Set dlrg = RefColumnRange(dws.Range(dlFirst))
    If dlrg Is Nothing Then Exit Sub

    Dim drCount As Long: drCount = dlrg.Rows.Count
    Dim dlData As Variant: dlData = GetColumnRange(dlrg)
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim sCols() As String: sCols = Split(sColsList, ",")
    Dim nUpper As Long: nUpper = UBound(sCols)
    
    Dim slrg1 As Range: Set slrg1 = RefColumnRange(sws.Range(slFirst1))
    
    Dim sData As Variant: ReDim sData(0 To nUpper)
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To nUpper + 1)
    
    Dim crg As Range
    Dim rIndex As Variant
    Dim n As Long
    Dim r As Long
    
    If Not slrg1 Is Nothing Then
        For n = 0 To nUpper
            If n <> sl2ColIndex Then
                Set crg = slrg1.EntireRow.Columns(sCols(n))
                sData(n) = GetColumnRange(crg)
            End If
        Next n
        For r = 1 To drCount
            rIndex = Application.Match(dlData(r, 1), slrg1, 0)
            If IsNumeric(rIndex) Then
                For n = 0 To nUpper
                    If n <> sl2ColIndex Then
                        dData(r, n + 1) = sData(n)(rIndex, 1)
                    End If
                Next n
            End If
        Next r
    End If
    
    Dim slrg2 As Range: Set slrg2 = RefColumnRange(sws.Range(slFirst2))
    
    If Not slrg2 Is Nothing Then
        n = sl2ColIndex
        Set crg = slrg2.EntireRow.Columns(sCols(n))
        sData(n) = GetColumnRange(crg)
        For r = 1 To drCount
            rIndex = Application.Match(dlData(r, 1), slrg2, 0)
            If IsNumeric(rIndex) Then
                dData(r, n + 1) = sData(n)(rIndex, 1)
            End If
        Next r
    End If
    
    With dws.Range(dFirst).Resize(, nUpper + 1)
        .Resize(drCount).Value = dData
        .Resize(.Worksheet.Rows.Count - .Row - drCount + 1) _
            .Offset(drCount).ClearContents
    End With

End Sub

Function RefColumnRange( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    
    Dim lCell As Range
    With FirstCellRange.Cells(1)
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumnRange = .Resize(lCell.Row - .Row + 1)
    End With

End Function

Function GetColumnRange( _
    ByVal ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    
    Dim rCount As Long: rCount = ColumnRange.Rows.Count
    Dim cData As Variant
    With ColumnRange.Columns(1)
        If rCount = 1 Then
            ReDim cData(1 To 1, 1 To 1): cData(1, 1) = .Value
        Else
            cData = .Value
        End If
    End With
    
    GetColumnRange = cData
End Function