未打开多工作簿取数VBA代码优化求助：大数据量运行过慢

我花了几周调试下面的VBA代码，它能不用打开多个工作簿就提取数据，但要填充约150行、1700列（总计25.5万个单元格）的数据，运行速度太慢。我也试过用公式替代VBA实现，但对“必须复制粘贴为值才能得到结果”的逻辑有疑问，求帮忙解决。

工作簿样式说明 #

包含用于定位外部数据源的列：B列是外部工作簿路径、C列是文件名、D列是工作表名；待填充数据区域为I列至BMQ列，每行对应一组外部数据提取规则。

原VBA代码 #

Sub Worksheet_Change()
Dim Rng As Range
Dim r As Long
Dim s As String
Dim f As String
Dim i As Long
On Error GoTo ErrHandler
Dim m As Long
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.DisplayStatusBar = False
    
    m = Sheets("ECHEANCIER").Range("A" & Rows.Count).End(xlUp).Row
        Range("I5:BMQ" & m).ClearContents
    For r = 5 To m
        For i = 9 To 1000
            s = "'" & Range("B" & r).Value & "[" & Range("C" & r).Value & "]" & Range("D" & r).Value & "'!"
            Sheets("ECHEANCIER").Cells(r, i).FormulaR1C1 = "=RC[-1]*(IF(ISNA(INDEX(" & s & " R1C1:R1000C1000,MATCH(R[" & 4 - r & "]C," & s & "C1,0),MATCH(RC7," & s & " R1,0)+1)),1,INDEX(" & s & " R1C1:R1000C1000,MATCH(R[" & 4 - r & "]C," & s & "C1,0),MATCH(RC7," & s & " R1,0)+1)))"
                
                If Sheets("ECHEANCIER").Cells(r, i).Value = 0 Then
                Sheets("ECHEANCIER").Cells(r, i).ClearContents
                Exit For
                End If
                Range("I" & r & ":BMQ" & r).Copy
                Range("I" & r & ":BMQ" & r).PasteSpecial Paste:=xlPasteValues
        Next
    Next
ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

VBA效率优化方案 #

核心慢因分析 #

原代码效率低的关键问题：

• 嵌套循环逐单元格写公式再转值，工作表IO操作过于频繁
• 每行执行整行复制粘贴值，完全冗余
• 每个单元格都重复调用外部工作簿的INDEX/MATCH，重复计算开销极大

优化后的代码 #

Sub Worksheet_Change()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim extWBPath As String, extWBName As String, extWSName As String
    Dim extWS As Worksheet
    Dim matchRow As Long, matchCol As Long
    Dim resultVal As Double
    Dim targetArr As Variant
    Dim startCol As Long, maxCol As Long
    
    On Error GoTo ErrHandler
    ' 锁定应用环境，减少不必要的系统开销
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        .DisplayAlerts = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual ' 关闭自动计算，避免公式写入时反复触发
    End With
    
    Set ws = ThisWorkbook.Sheets("ECHEANCIER")
    lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    startCol = 9 ' 对应I列
    maxCol = 1000 ' 原代码的列数上限
    
    ' 清空目标区域并转为数组，内存操作提速核心
    ws.Range(ws.Cells(5, startCol), ws.Cells(lastRow, maxCol)).ClearContents
    targetArr = ws.Range(ws.Cells(5, startCol), ws.Cells(lastRow, maxCol)).Value
    
    For r = 5 To lastRow
        ' 获取当前行的外部数据源信息
        extWBPath = ws.Range("B" & r).Value
        extWBName = ws.Range("C" & r).Value
        extWSName = ws.Range("D" & r).Value
        
        ' 一次性隐藏打开外部工作簿，避免多次跨簿链接调用
        With Workbooks.Open(Filename:=extWBPath & "\" & extWBName, ReadOnly:=True, UpdateLinks:=xlUpdateLinksNever)
            Set extWS = .Sheets(extWSName)
            
            ' 提前计算匹配行和列，避免重复调用MATCH
            matchRow = Application.Match(ws.Range("A4").Value, extWS.Columns(1), 0) ' 原代码R[4-r]C对应固定A4单元格
            matchCol = Application.Match(ws.Range("G" & r).Value, extWS.Rows(1), 0) + 1
            
            ' 确定乘数因子
            If Not IsError(matchRow) And Not IsError(matchCol) Then
                resultVal = extWS.Cells(matchRow, matchCol).Value
            Else
                resultVal = 1
            End If
            
            ' 内存中计算当前行的累积乘积
            Dim col As Long
            Dim prevVal As Double
            prevVal = ws.Cells(r, startCol - 1).Value ' 取H列初始值
            For col = startCol To maxCol
                prevVal = prevVal * resultVal
                If prevVal = 0 Then
                    Exit For ' 值为0时停止填充
                End If
                targetArr(r - 4, col - startCol + 1) = prevVal ' 数组索引转换
            Next col
            
            .Close SaveChanges:=False ' 关闭外部工作簿，不保存
        End With
    Next r
    
    ' 一次性把数组写回工作表，完成批量填充
    ws.Range(ws.Cells(5, startCol), ws.Cells(lastRow, maxCol)).Value = targetArr
    
ExitHandler:
    ' 恢复应用环境
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .DisplayStatusBar = True
        .Calculation = xlCalculationAutomatic
    End With
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

优化点说明 #

• 数组批量操作：将目标区域读入内存数组，计算完成后一次性写回，把数百次IO操作压缩为1次，这是提速最关键的一步
• 单次打开外部工作簿：原代码每个单元格都通过链接调用外部文件，改为每行打开一次（隐藏只读），大幅减少跨工作簿通信开销
• 提前计算匹配值：每行只计算一次行和列的MATCH结果，避免重复计算
• 手动计算模式：关闭自动计算，避免公式写入时反复触发工作表计算
• 取消冗余粘贴操作：直接在数组中计算最终值，不需要先写公式再转值

公式实现的疑问解答 #

你提到的“必须复制粘贴为值”的问题，本质是跨工作簿公式的特性导致：

1. 链接依赖问题：外部工作簿未打开时，公式会保留完整路径链接，结果依赖外部文件的可用性；如果外部文件移动、重命名或删除，公式会报错
2. 性能与稳定性问题：大量跨工作簿公式会导致文件打开慢、计算卡顿，粘贴为值可以固化结果，减少文件体积和后续加载开销

公式实现优化方案 #

方案1：动态数组公式（Excel 365/2021+）

在I5单元格输入以下公式，按回车后自动填充整行（甚至整区域），无需手动拖拽：

=LET(
    extPath,B5,extWB,C5,extWS,D5,
    extCol1,"'"&extPath&"["&extWB&"]"&extWS&"'!C1",
    extRow1,"'"&extPath&"["&extWB&"]"&extWS&"'!R1",
    extRange,"'"&extPath&"["&extWB&"]"&extWS&"'!R1C1:R1000C1000",
    matchRow,MATCH($A4,INDIRECT(extCol1),0),
    matchCol,MATCH(G5,INDIRECT(extRow1),0)+1,
    factor,IF(ISNA(INDEX(INDIRECT(extRange),matchRow,matchCol)),1,INDEX(INDIRECT(extRange),matchRow,matchCol)),
    SCAN(H5,SEQUENCE(,992),LAMBDA(a,x,a*factor))
)

• 用SCAN函数实现累积乘积的批量计算，一行公式搞定整行数据
• 用LET函数简化公式结构，减少重复引用外部路径，提升可读性

方案2：快速固化公式为值

如果必须粘贴为值，可使用以下快捷操作：

• 选中公式区域，按Ctrl+C复制
• 右键选择粘贴值，或按Ctrl+Alt+V后选择“值”选项
• 也可以用VBA批量处理，但优化后的VBA已经直接生成值，无需走公式转值流程

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