有没有办法加快这个 VBA 宏的运行速度，以在 1000 次的大范围内执行 Vlookup？

Question

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

Answer 1

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
        Application.Goto Reference:=dvrg.Cells(1), Scroll:=True
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Ventilation updated.", vbInformation

End Sub

Answer 2

This (using Match once per row and copying the data as a single block) will be faster:

Sub Questionnaire_to_Ventilation()
    Dim wsV As Worksheet, wsSQ As Worksheet, rngData As Range
    Dim i As Long, v, m
    
    Set wsV = ThisWorkbook.Worksheets("Ventilation")
    Set wsSQ = ThisWorkbook.Worksheets("Scheduling Questionnaire")
    Set rngData = wsSQ.Range("$B$11:$N$3337")
    
    Application.ScreenUpdating = False
    For i = 10 To wsV.Cells(wsV.Rows.Count, "E").End(xlUp).Row
        v = wsV.Cells(i, "E").Value
        If Len(v) > 0 Then   'the value to look up
            m = Application.Match(v, rngData.Columns(1), 0) 'match in data?
            If Not IsError(m) Then
                'got a match:copy over values from I:N on that row
                wsV.Cells(i, "Y").Resize(1, 6).Value = _
                         rngData.Rows(m).Cells(8).Resize(1, 6).Value
            End If
        End If
    Next i
End Sub