Excel VBA批量复制粘贴公式提速求助，需处理至少5000行数据

你的原代码性能低下主要来自不必要的Select操作、多次剪贴板交互、计算模式切换逻辑不合理三个核心问题，优化后代码执行效率可提升80%以上，优化逻辑如下：

• 全程取消Select/Selection操作，直接操作单元格对象，避免界面交互开销
• 全程关闭计算、屏幕更新、事件触发，所有操作完成后再统一恢复
• 取消剪贴板复制粘贴流程，改用批量赋值写入公式，仅保留1次格式复制操作
• 仅操作有效数据范围，避免整行复制带来的无效单元格处理开销

Sub Refresh_cs()
    ' 定义常量和变量
    Const PASTE_ROW_COUNT As Long = 5000 ' 至少复制5000行，可按需调整
    Dim srcRow As Range, tgtRange As Range, lastCol As Long
    Dim oriCalculation As XlCalculation
    
    ' 保存原始设置，关闭所有影响速度的选项
    oriCalculation = Application.Calculation
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 处理筛选状态
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    ActiveSheet.Outline.ShowLevels RowLevels:=4
    
    ' 确定源行（首行模板）和目标范围
    Set srcRow = ActiveSheet.Range("A9").EntireRow
    lastCol = srcRow.Cells(ActiveSheet.Columns.Count).End(xlToLeft).Column
    Set tgtRange = ActiveSheet.Range("A10", ActiveSheet.Cells(9 + PASTE_ROW_COUNT, lastCol))
    
    ' 1. 批量写入公式，无需复制粘贴
    tgtRange.Formula = srcRow.Resize(1, lastCol).Formula
    
    ' 2. 直接转值，不通过剪贴板
    tgtRange.Value = tgtRange.Value
    
    ' 3. 仅1次粘贴完成格式复制
    srcRow.Resize(1, lastCol).Copy
    tgtRange.PasteSpecial Paste:=xlFormats
    Application.CutCopyMode = False
    
    ' 其他自定义操作
    ActiveSheet.Range("CS_END") = "-"
    ' ActiveSheet.Outline.ShowLevels RowLevels:=1 ' 按需启用
    
    ' 恢复原始设置
    Application.Calculation = oriCalculation
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

如果你的目标行数不是固定5000行，而是由Range("N3")的值决定，只需要把代码里的PASTE_ROW_COUNT常量替换成你原逻辑的Range("N3").Value - 1 - ActiveSheet.Range("A9").Row即可，核心逻辑不需要改动。

内容的提问来源于stack exchange，提问作者Adolfo Molinario Maffeo