优化批量跨工作簿数据复制VBA代码解决内存溢出等问题

问题分析 #

原代码重复编写相同的「打开工作簿-复制数据-关闭工作簿」逻辑，不仅造成代码冗余、过程体积过大，还会因频繁操作工作簿占用过多内存，最终引发内存不足或过程过大的错误。

优化思路 #

• 统一管理目标文件路径与对应源单元格的映射关系，彻底消除重复代码块
• 用单元格直接赋值替代Copy/PasteSpecial，减少剪贴板占用，大幅提升运行效率
• 仅初始化一次主工作簿和工作表，避免重复创建对象浪费资源
• 增加错误处理，防止单个文件异常中断整个批量任务

优化后的代码 #

Sub BatchCopyData()
    Dim mainWb As Workbook
    Dim mainWs As Worksheet
    Dim targetPath As String
    Dim sourceCellAddr As String
    Dim targetWb As Workbook
    Dim targetWs As Worksheet
    Dim i As Integer
    ' 定义目标文件路径和对应源单元格的映射数组
    ' 格式：数组元素 = Array("目标文件完整路径", "源单元格地址")
    Dim fileMapping As Variant
    fileMapping = Array( _
        Array("D:\work\old server\Cards Tests\New folder\data\1-xxxxxxx.xlsm", "A2"), _
        Array("D:\work\old server\Cards Tests\New folder\data\1043-xxxxxxx.xlsm", "A52"), _
        Array("D:\work\old server\Cards Tests\New folder\data\1044-xxxxxxx.xlsm", "A53") _
        ' 可继续添加更多映射，无需重复编写代码块
    )
    
    ' 初始化主工作簿和工作表，仅执行一次
    Set mainWb = ThisWorkbook ' 假设代码在info.xlsm中运行，用ThisWorkbook更安全
    Set mainWs = mainWb.Worksheets("Sheet2")
    
    ' 关闭屏幕更新和事件，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 遍历所有目标文件
    For i = LBound(fileMapping) To UBound(fileMapping)
        targetPath = fileMapping(i)(0)
        sourceCellAddr = fileMapping(i)(1)
        
        On Error Resume Next ' 捕获文件打开错误
        Set targetWb = Workbooks.Open(targetPath)
        If Err.Number <> 0 Then
            Debug.Print "无法打开文件：" & targetPath ' 在立即窗口打印错误信息
            Err.Clear
            GoTo NextFile ' 跳过错误文件，继续处理下一个
        End If
        On Error GoTo 0 ' 恢复默认错误捕获
        
        ' 定位目标工作表
        Set targetWs = targetWb.Worksheets("Sheet1")
        ' 直接赋值替代复制粘贴，效率更高且不占用剪贴板
        targetWs.Range("M4").Value = mainWs.Range(sourceCellAddr).Value
        
        ' 保存并关闭目标工作簿
        targetWb.Close SaveChanges:=True
NextFile:
    Next i
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "批量复制完成！"
End Sub

额外优化建议 #

• 若目标文件数量极多，可将映射关系放在主工作簿的专属工作表中（比如新增「文件列表」工作表，A列存路径、B列存源单元格地址），通过读取工作表数据动态生成映射数组，无需修改代码即可更新任务列表
• 若目标文件均为同一路径下的特定格式文件（如所有.xlsm），可使用Dir函数自动遍历文件夹获取文件路径，无需手动维护路径列表

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