优化Excel VBA代码执行效率：24000行数据耗时超30分钟求方案

Your current code is taking way too long because of two critical inefficiencies:

• Nested loops that compare every row in HR_Report to every row in APAC_L_R (this gives you a worst-case runtime of O(n*m), which is brutal for 24k+ rows)
• Constantly reading/writing individual worksheet cells (cell operations are one of the slowest things you can do in VBA)

Here's an optimized version that'll cut your runtime down to seconds instead of minutes:

Sub populateHRData17_Optimized()
    Dim report As Worksheet, hr As Worksheet, apac As Worksheet
    Dim hrData As Variant, apacData As Variant, results As Variant
    Dim apacDict As Object
    Dim i As Long, x As Long, lastRowHR As Long, lastRowAPAC As Long
    
    ' Turn off Excel features that slow down code execution
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' Set worksheet references (use ThisWorkbook for reliability)
    Set report = ThisWorkbook.Worksheets("Report")
    Set hr = ThisWorkbook.Worksheets("HR_Report")
    Set apac = ThisWorkbook.Worksheets("APAC_L_R")
    Set apacDict = CreateObject("Scripting.Dictionary")
    
    ' Get last used rows to avoid looping through empty cells
    lastRowHR = hr.Cells(hr.Rows.Count, 3).End(xlUp).Row
    lastRowAPAC = apac.Cells(apac.Rows.Count, 2).End(xlUp).Row
    
    ' Load all data into arrays (way faster than reading cells one by one)
    hrData = hr.Range("C2:C" & lastRowHR).Value
    apacData = apac.Range("B2:B" & lastRowAPAC).Value
    
    ' Populate dictionary with APAC values for instant lookups
    For i = 1 To UBound(apacData)
        ' Skip duplicate keys (adjust if you need to handle duplicates differently)
        If Not apacDict.Exists(apacData(i, 1)) Then
            apacDict.Add apacData(i, 1), True
        End If
    Next i
    
    ' Prepare results array to store matches
    ReDim results(1 To UBound(hrData), 1 To 1)
    x = 1
    For i = 1 To UBound(hrData)
        ' Check if HR value exists in APAC dictionary (O(1) speed)
        If apacDict.Exists(hrData(i, 1)) Then
            results(x, 1) = hrData(i, 1)
            x = x + 1
        End If
    Next i
    
    ' Write all results to Report sheet in one go (single batch operation)
    If x > 1 Then
        report.Range("A2:A" & (x + 1)).Value = results
    End If
    
    ' Restore Excel settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "HR data populated successfully!", vbInformation
End Sub

Key Improvements: #

• Array Operations: We load all relevant data into VBA arrays first—array access is hundreds of times faster than reading/writing individual cells.
• Dictionary Lookups: Using a Scripting.Dictionary turns your nested loop O(n*m) lookup into O(n) (constant time per lookup), which is a massive speed boost for large datasets.
• Batch Writing: Instead of writing to the Report sheet row by row, we collect all results in an array and write them all at once.
• Disabled Excel Features: Turning off screen updating, automatic calculation, and events eliminates unnecessary overhead while the code runs.

Quick Notes: #

• If you need to handle duplicate values in APAC_L_R (e.g., return multiple matches), you can adjust the dictionary to store collections instead of just True.
• ThisWorkbook is more reliable than ActiveWorkbook here—it ensures you're targeting the workbook containing the code, not whatever workbook happens to be active.

内容的提问来源于stack exchange，提问作者Josh Hudson