将12个不同工作簿数据合并到单工作簿，如何优化VBA代码提升运行速度

核心优化点 #

• 新增禁用系统事件、弹窗提示，避免链接更新、确认弹窗等不必要的耗时
• 打开外部工作簿时启用只读模式、关闭链接更新，大幅降低共享文件夹下的文件打开耗时
• 提前缓存主工作簿对象，避免重复按名称检索工作簿的寻址开销
• 写入数据前先删除旧命名表，而非仅清空单元格内容，避免命名冲突校验和报错风险
• 固定路径提取为全局常量，避免子过程重复赋值
• 增加错误捕获分支，保证运行异常时也能恢复Excel的默认配置

优化后完整代码 #

Option Explicit
' 统一配置文件路径，仅需修改一次
Const FILE_PATH As String = "/Users/dimagoroh/Desktop/nastia stuff /"
Dim wbMain As Workbook

Sub callstuff()
    ' 提前缓存主工作簿对象
    Set wbMain = ThisWorkbook
    
    ' 批量关闭系统开销项
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
    
    On Error GoTo ErrHandler
    
    ' 调用导入逻辑，可按需增减行
    Call CurrentRegionArray("helper1", "book2.xlsx", "sheet2", "J4")
    Call CurrentRegionArray("helper2", "book3.xlsx", "sheet3", "J4")
    Call CurrentRegionArray("helper3", "book4.xlsx", "sheet4", "J4")
    Call CurrentRegionArray("helper4", "book5.xlsx", "sheet5", "J4")
    Call CurrentRegionArray("helper5", "book6.xlsx", "sheet6", "J4")
    Call CurrentRegionArray("helper6", "book7.xlsx", "sheet7", "J4")
    Call CurrentRegionArray("helper7", "book8.xlsx", "sheet8", "J4")
    Call CurrentRegionArray("helper8", "book9.xlsx", "sheet9", "J4")
    Call CurrentRegionArray("helper9", "book10.xlsx", "sheet10", "J4")
    Call CurrentRegionArray("helper10", "book11.xlsx", "sheet11", "J4")
    Call CurrentRegionArray("helper11", "book12.xlsx", "sheet12", "J4")
    ' 如需第12个工作簿导入可自行补充对应行
    
ErrHandler:
    ' 恢复系统默认配置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .AskToUpdateLinks = True
    End With
    
    If Err.Number <> 0 Then
        MsgBox "运行出错：" & Err.Description, vbCritical
    End If
End Sub

Sub CurrentRegionArray(TableName As String, WorkBookName As String, SheetName As String, RangeName As String)
    Dim wbSource As Workbook
    Dim oarray As Variant
    Dim rngTable As Range
    Dim wsTarget As Worksheet
    Dim oldListObj As ListObject
    
    ' 只读打开源工作簿，不更新链接
    Set wbSource = Application.Workbooks.Open(Filename:=FILE_PATH & WorkBookName, ReadOnly:=True, UpdateLinks:=False)
    ' 读取源数据到数组
    oarray = wbSource.Worksheets("sheet1").ListObjects("leavetracker").DataBodyRange.Value
    ' 关闭源工作簿，无需保存
    wbSource.Close SaveChanges:=False
    
    ' 绑定目标工作表
    Set wsTarget = wbMain.Worksheets(SheetName)
    
    ' 先删除目标表已存在的旧命名表
    For Each oldListObj In wsTarget.ListObjects
        oldListObj.Delete
    Next oldListObj
    
    ' 清空旧数据写入新数组
    With wsTarget.Range(RangeName)
        .CurrentRegion.Clear
        .Resize(UBound(oarray, 1), UBound(oarray, 2)) = oarray
    End With
    
    ' 新建命名表
    Set rngTable = wsTarget.Range(RangeName).CurrentRegion
    wsTarget.ListObjects.Add(xlSrcRange, rngTable, , xlYes).Name = TableName
    
    ' 释放内存
    Erase oarray
    Set wbSource = Nothing
    Set wsTarget = Nothing
    Set rngTable = Nothing
End Sub

额外提速建议 #

如果数据量很大还可以进一步优化：

• 可先将共享文件夹内的文件临时复制到本地磁盘处理，完成后再删除临时文件，避免网络传输耗时
• 如果源表格的结构固定，可不用每次删除重建表，直接对原有表的数据区域赋值即可，省去新建表的开销

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