VBA跨工作簿批量复制指定单元格提速方案咨询

你的代码运行效率低，核心是这几个问题：

• 每次循环都重复打开同一个工作簿，IO开销极大
• 频繁用Select/Activate切换窗口，VBA对这类操作的性能损耗很高
• 逐单元格复制粘贴，没利用Excel的批量操作能力
• lastRow定义为String类型，既容易出错也没必要

下面是优化后的代码，性能能提升几十倍：

Sub BatchCopyData()
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim sourceData As Variant
    Dim targetRange As Range
    Dim fileToOpen As Variant
    Dim i As Long
    Dim lastRow As Long
    
    ' 关闭Excel界面刷新、自动计算，减少运行时的性能损耗
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 指定Book1的目标工作表，把Sheet1改成你实际用的表名
    Set targetWS = Workbooks("Book1").Worksheets("Sheet1")
    ' 选择源文件
    fileToOpen = Application.GetOpenFilename(Filefilter:="Excel Files (*.xls*), *.xls*", Title:="Select File")
    If fileToOpen = False Then Exit Sub ' 用户取消选择则直接退出
    
    ' 只打开一次源工作簿，读取所有需要的数据
    Set sourceWB = Application.Workbooks.Open(fileToOpen)
    Set sourceWS = sourceWB.ActiveSheet ' 如果数据在固定工作表，可改成sourceWB.Worksheets("你的表名")
    
    ' 一次性把第3行B列到BK列（共62个单元格）的数据读到内存数组
    sourceData = sourceWS.Range(sourceWS.Cells(3, 2), sourceWS.Cells(3, 63)).Value
    
    ' 获取Book1中C列的起始写入行
    lastRow = targetWS.Cells(targetWS.Rows.Count, "C").End(xlUp).Row + 1
    
    ' 循环处理每个数据，批量填充358次
    For i = 1 To UBound(sourceData, 2)
        ' 直接在目标区域批量写入相同值，替代复制粘贴
        Set targetRange = targetWS.Cells(lastRow, "C").Resize(358, 1)
        targetRange.Value = sourceData(1, i)
        lastRow = lastRow + 358 ' 更新下一次的起始行
    Next i
    
    ' 关闭源工作簿，不保存（如果不需要修改源文件）
    sourceWB.Close SaveChanges:=False
    
    ' 恢复Excel的默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "数据批量复制完成！"
End Sub

关键优化点说明 #

1. 单次IO操作：原代码每次循环都打开同一文件，现在只打开一次读取所有数据，彻底消除重复IO的性能浪费
2. 内存数组读取：一次性把需要的62个单元格数据读到内存数组，比逐单元格读取快数倍
3. 批量填充替代复制粘贴：用Resize直接生成358行相同数据，避免逐单元格复制粘贴的繁琐操作
4. 禁用界面刷新：运行时关闭Excel界面刷新和自动计算，减少不必要的资源消耗
5. 取消Select/Activate：直接引用工作表和单元格对象，不需要切换窗口，大幅减少操作开销

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