优化VBA代码提升运行速度——5000+数据运行耗时2分钟求助

核心问题分析 #

原代码采用双层嵌套循环遍历两个工作表，5000条数据会产生2500万次循环，再加上每次循环都直接读写单元格（VBA中最慢的操作之一），这是耗时的主要原因。此外还有变量未显式声明、逻辑冗余等问题。

具体优化措施 #

1. 强制声明变量，避免隐式类型损耗 #

在模块顶部添加Option Explicit，强制所有变量先声明再使用，避免因默认变体型变量导致的性能浪费和逻辑错误。

2. 用内存数组替代单元格直接读写 #

把需要处理的工作表区域一次性读入内存数组，循环时直接操作数组，最后一次性写回工作表，彻底减少单元格IO的开销。

3. 用字典构建索引，替换内层循环 #

将GAC表中需要匹配的核心字段（产品+工厂）作为键，对应最小日期作为值存入字典，把原O(n*m)的时间复杂度降到O(n+m)，大幅提升匹配效率。

4. 关闭更多Excel后台功能 #

除了ScreenUpdating，额外关闭自动计算和事件触发，进一步减少运行时的资源消耗。

优化后的完整代码 #

Option Explicit

Sub FindEarliestDate_Optimized()
    ' 关闭Excel后台消耗功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim gacSheet As Worksheet, nopSheet As Worksheet
    Set gacSheet = ThisWorkbook.Sheets("GAC")
    Set nopSheet = ThisWorkbook.Sheets("nop")
    
    Dim gacLastRow As Long, nopLastRow As Long
    gacLastRow = gacSheet.Cells(gacSheet.Rows.Count, "L").End(xlUp).Row
    nopLastRow = nopSheet.Cells(nopSheet.Rows.Count, "K").End(xlUp).Row
    
    ' 读取GAC表核心数据到数组（A-L列，对应原代码用到的字段）
    Dim gacArr As Variant
    gacArr = gacSheet.Range("A3:L" & gacLastRow).Value
    
    ' 构建字典：键为"产品|工厂"，值为符合条件的最小日期
    Dim gacDict As Object
    Set gacDict = CreateObject("Scripting.Dictionary")
    
    Dim j As Long, key As String, currentDate As Date
    ' 注意：原代码中earliestDate未定义，这里假设它是一个已存在的日期变量，若实际为nop表BZ列值需调整逻辑
    For j = 1 To UBound(gacArr, 1)
        key = gacArr(j, 6) & "|" & gacArr(j, 1) ' 产品（F列）+工厂（A列）作为匹配键
        If gacArr(j, 5) >= earliestDate Then ' 筛选gacBuyDate（E列）满足条件的记录
            currentDate = gacArr(j, 12) ' 取gacDate1（L列）
            If Not gacDict.Exists(key) Then
                gacDict(key) = currentDate
            Else
                ' 保留最小的日期
                If currentDate < gacDict(key) Then
                    gacDict(key) = currentDate
                End If
            End If
        End If
    Next j
    
    ' 读取nop表核心数据到数组（G-K列：G=EFTDate，I=FTY，K=Prod）
    Dim nopArr As Variant, resultArr As Variant
    nopArr = nopSheet.Range("G3:K" & nopLastRow).Value
    ReDim resultArr(1 To UBound(nopArr, 1), 1 To 1) ' 存储最终结果
    
    Dim i As Long, nopKey As String
    For i = 1 To UBound(nopArr, 1)
        nopKey = nopArr(i, 5) & "|" & nopArr(i, 3) ' 产品（K列）+工厂（I列）作为匹配键
        ' 匹配原代码中nopEFTDate = earliestDate的条件
        If nopArr(i, 1) = earliestDate Then
            resultArr(i, 1) = IIf(gacDict.Exists(nopKey), gacDict(nopKey), "")
        Else
            resultArr(i, 1) = ""
        End If
    Next i
    
    ' 一次性将结果写入nop表BA列
    nopSheet.Range("BA3:BA" & nopLastRow).Value = resultArr
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "处理完成！"
End Sub

补充说明 #

• 原代码中earliestDate变量未定义，优化代码中假设它是已存在的日期变量；若实际为nop表BZ列的对应行值，需将BZ列数据读入nopArr，循环时取对应值即可。
• 代码中使用CreateObject("Scripting.Dictionary")无需额外引用库，兼容性更强；若要提前引用，可勾选Microsoft Scripting Runtime。
• 数组列索引对应规则：工作表A列为数组第1列，B列为第2列，以此类推，需确保索引与原代码字段对应正确。

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