[SOLVED] Is there a way to speed up this VBA macro running to perform a Vlookup on a large range 1000's of times?

Issue

Sub Questionnaire_to_Ventilation()
'
' Questionnaire_to_Ventilation Macro
'
' Keyboard Shortcut: Ctrl+Shift+M
'
Application.ScreenUpdating = False
    Sheets("Ventilation").Select
    Dim LRow As Long
    LRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "E").End(xlUp).Row
    For i = 0 To LRow
        For col = 8 To 13
            Sheets("Ventilation").Range("Y10").Offset(i, col - 8) = Application.IfError(Application.VLookup _
            (Sheets("Ventilation").Range("E10").Offset(i, 0), Sheets("Scheduling Questionnaire").Range("$B$11:$N$3337"), col, False), "")
        Next col
    Next i
Range("Y10").Select
Application.ScreenUpdating = True
End Sub

Solution

INDEX/MATCH replaces VLOOKUP (VBA Formula)

Option Explicit

Sub Questionnaire_to_Ventilation()
'
' Questionnaire_to_Ventilation Macro
'
' Keyboard Shortcut: Ctrl+Shift+M
'
' Write the following formula...
' =IFERROR(INDEX('Scheduling Questionnaire'!I$11:I$3337,
'     MATCH($E10,'Scheduling Questionnaire'!$B$11:$B$3337,0)),"")
' ... to the range 'Y10:ADlr' and remove the formulas (leaving values).
'
    Const sName As String = "Scheduling Questionnaire"
    Const slCol As String = "B"
    Const svCol As String = "I"
    Const sRows As String = "11:3337"
    
    Const dName As String = "Ventilation"
    Const dlCol As String = "E"
    Const dvCol As String = "Y"
    Const dfRow As Long = 10
    
    Const cCount As Long = 6
    
    Dim slAddress As String, svAddress As String
    
    With ThisWorkbook.Worksheets(sName)
        Dim sNameRef As String: sNameRef = "'" & sName & "'!"
        slAddress = sNameRef & .Rows(sRows).Columns(slCol).Address
        svAddress = sNameRef & .Rows(sRows).Columns(svCol).Address(, 0)
    End With
    
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets(dName)
        Dim dlRow As Long: dlRow = .Cells(.Rows.Count, dlCol).End(xlUp).Row
        Dim dlrg As Range
        Set dlrg = .Cells(dfRow, dlCol).Resize(dlRow - dfRow + 1)
        Dim dvrg As Range
        Set dvrg = dlrg.EntireRow.Columns(dvCol).Resize(, cCount)
        Dim dFormula As String
        dFormula = "=IFERROR(INDEX(" & svAddress & ",MATCH(" _
            & dlrg.Cells(1).Address(0) & "," & slAddress & ",0)),"""")"
        'Debug.Print dFormula
        dvrg.Formula = dFormula
        dvrg.Value = dvrg.Value
        .Select ' ensuring the following line doesnt't fail
        dvrg.Cells(1).Select
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Ventilation updated.", vbInformation

End Sub

Answered By – VBasic2008

Answer Checked By – Gilberto Lyons (BugsFixing Admin)