Excel VBA宏运行先快后慢 数据导出速度骤降问题排查

• 临时表堆积：每处理1条数据就会在源工作簿中新建1个临时工作表，但处理完成后从未删除这些表。随着循环次数增加，源工作簿内工作表数量线性上涨，工作簿内存占用持续升高，达到Excel进程内存阈值后，系统会调用磁盘虚拟内存交换数据，直接导致速度从秒级跌到分钟级。
• 低效操作过多：代码中大量使用Activate、Select、剪贴板复制粘贴操作，这类操作的执行效率本身比直接对象赋值低1~2个数量级，且工作表数量越多，对象切换、剪贴板调度的耗时会同步上涨。
• 未禁用Excel默认交互逻辑：运行过程中没有关闭屏幕刷新、自动重算、事件触发，每次写入单元格、新增工作表都会触发全工作簿的重算和屏幕重绘，工作表越多，单次触发的耗时越长。
• 隐式引用开销：代码中多处Range()、Cells()调用未指定所属工作表，默认依赖当前活动工作表，既容易出现引用错误，也会增加对象寻址的额外开销。
• 格式匹配错误：需求是导出制表符分隔文件，但代码中使用的xlCSVUTF8是逗号分隔CSV格式，不符合预期。

• 直观检查：运行宏处理3~5条数据后手动终止，查看源工作簿的工作表标签栏，会发现已经新增了多个对应wksName的无用工作表，可直接确认临时表堆积问题。
• 内存监控：打开任务管理器查看Excel进程的内存占用，会看到内存随宏运行持续上涨，速度骤降节点通常对应内存达到单进程阈值（32位Excel约2GB，64位Excel受系统可用内存限制）。
• 分段计时：在循环内的新建临时表、单元格写入、复制粘贴、保存关闭等节点前后加时间打印，可快速定位耗时随循环次数暴涨的具体环节。

核心优化逻辑是取消源工作簿内的临时表创建，用数组一次性读写数据，禁用所有拖慢速度的Excel默认功能，从根源上消除内存上涨的诱因。
优化后的参考代码：

Sub DataMove()
    Dim wksName As String
    Dim FolderPath As String
    Dim OrgWks As Worksheet
    Dim wb As Workbook
    Dim RowNum As Long
    Dim ColNum As Long
    Dim NameRow As Long
    Dim arrIndex As Long
    Dim NumRows As Long
    Dim NumCols As Long
    Dim dataRowCount As Long
    Dim dataArr As Variant
    
    ' 关闭所有影响运行速度的Excel功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ' 初始化变量，直接绑定工作表对象避免反复通过名称引用
    Set OrgWks = ActiveSheet
    FolderPath = OrgWks.Parent.Path
    RowNum = 4
    ColNum = 8
    
    ' 所有Range调用明确指定所属工作表，避免隐式引用
    NumRows = OrgWks.Range("A1", OrgWks.Range("A1").End(xlDown)).Rows.Count
    NumCols = OrgWks.Range("G4", OrgWks.Range("G4").End(xlToRight)).Columns.Count + 6
    ' 提前计算单条数据的导出行数，给存储数组分配空间
    dataRowCount = ((NumCols - 8) \ 3) + 1
    ReDim dataArr(1 To dataRowCount, 1 To 2)
    
    While RowNum <= NumRows
        NameRow = RowNum - 2
        wksName = OrgWks.Cells(NameRow, 29).Value
        arrIndex = 1
        ColNum = 8
        
        ' 直接将源数据读入内存数组，不在源工作簿创建任何临时表
        While ColNum < NumCols
            dataArr(arrIndex, 1) = OrgWks.Cells(RowNum, ColNum).Value
            dataArr(arrIndex, 2) = OrgWks.Cells(RowNum, ColNum - 1).Value
            ColNum = ColNum + 3
            arrIndex = arrIndex + 1
        Wend
        
        ' 新建导出工作簿，一次性写入数组数据，无需复制粘贴
        Set wb = Workbooks.Add
        wb.Sheets(1).Range("A1").Resize(dataRowCount, 2).Value = dataArr
        ' xlTextWindows为制表符分隔格式，匹配需求
        wb.SaveAs Filename:=FolderPath & "\" & wksName, FileFormat:=xlTextWindows, CreateBackup:=False
        wb.Close SaveChanges:=False
        
        RowNum = RowNum + 3
    Wend
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

优化后代码全程不会修改源工作簿结构，内存占用稳定，处理速度不会随数据量上涨衰减，单条数据处理耗时可稳定在毫秒级。

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