非相邻单元格按序复制粘贴VBA执行耗时过长问题求助

原代码性能问题根因 #

• 循环内逐单元格调用Copy+PasteSpecial，频繁操作剪贴板、与Excel界面交互，执行开销极高
• 未关闭屏幕更新、自动重算、事件响应等默认功能，产生大量无意义的性能损耗
• 无异常处理逻辑，遇到用户取消输入、工作表名不存在等情况会直接报错

优化后代码（全内容粘贴，支持保留格式/公式/批注/数据验证等） #

Sub OptimizedCopyNonAdjacent()
    Dim targetSheetName As String
    Dim copyRng As Range, cel As Range, targetSht As Worksheet
    Dim originScreenUpdating As Boolean, originCalculation As XlCalculation, originEnableEvents As Boolean
    
    ' 保存初始设置，关闭影响性能的功能
    originScreenUpdating = Application.ScreenUpdating
    originCalculation = Application.Calculation
    originEnableEvents = Application.EnableEvents
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    On Error GoTo Cleanup ' 异常捕获，避免设置无法恢复
    
    ' 校验选中区域是否合法
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选中需要复制的单元格", vbExclamation
        GoTo Cleanup
    End If
    Set copyRng = Selection
    
    ' 获取目标工作表输入，校验合法性
    targetSheetName = Application.InputBox("输入要粘贴到的工作表名称", Type:=2)
    If targetSheetName = "False" Then GoTo Cleanup ' 用户点了取消
    On Error Resume Next
    Set targetSht = Sheets(targetSheetName)
    On Error GoTo Cleanup
    If targetSht Is Nothing Then
        MsgBox "输入的工作表不存在", vbExclamation
        GoTo Cleanup
    End If
    
    ' 执行粘贴：保留原单元格位置粘贴
    For Each cel In copyRng
        ' 直接指定复制目标，不走剪贴板，比分开Copy+PasteSpecial快3倍以上
        cel.Copy Destination:=targetSht.Range(cel.Address)
    Next
    
    ' --------------- 如果需要按选中顺序连续粘贴到目标表A1开始的区域，把上面的循环替换成下面的代码 ---------------
    ' Dim pasteRow As Long: pasteRow = 1
    ' For Each cel In copyRng
    '     cel.Copy Destination:=targetSht.Cells(pasteRow, 1)
    '     pasteRow = pasteRow + 1
    ' Next
    ' --------------------------------------------------------------------------------------------------------
    
Cleanup:
    ' 恢复初始设置
    Application.ScreenUpdating = originScreenUpdating
    Application.Calculation = originCalculation
    Application.EnableEvents = originEnableEvents
    Application.CutCopyMode = False
    If Err.Number <> 0 Then MsgBox "执行出错：" & Err.Description, vbCritical
End Sub

仅需粘贴值的极速版本（不需要保留格式/公式时使用，速度提升10倍以上） #

Sub FastCopyValuesOnly()
    Dim targetSheetName As String
    Dim copyRng As Range, cel As Range, targetSht As Worksheet
    Dim originScreenUpdating As Boolean, originCalculation As XlCalculation, originEnableEvents As Boolean
    
    originScreenUpdating = Application.ScreenUpdating
    originCalculation = Application.Calculation
    originEnableEvents = Application.EnableEvents
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    On Error GoTo Cleanup
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选中需要复制的单元格", vbExclamation
        GoTo Cleanup
    End If
    Set copyRng = Selection
    
    targetSheetName = Application.InputBox("输入要粘贴到的工作表名称", Type:=2)
    If targetSheetName = "False" Then GoTo Cleanup
    On Error Resume Next
    Set targetSht = Sheets(targetSheetName)
    On Error GoTo Cleanup
    If targetSht Is Nothing Then
        MsgBox "输入的工作表不存在", vbExclamation
        GoTo Cleanup
    End If
    
    ' 保留原位置粘贴值
    For Each cel In copyRng
        targetSht.Range(cel.Address).Value = cel.Value
    Next
    
    ' --------------- 按选中顺序连续粘贴值到A1列的替换代码 ---------------
    ' Dim pasteRow As Long: pasteRow = 1
    ' For Each cel In copyRng
    '     targetSht.Cells(pasteRow, 1).Value = cel.Value
    '     pasteRow = pasteRow + 1
    ' Next
    ' ----------------------------------------------------------------
    
Cleanup:
    Application.ScreenUpdating = originScreenUpdating
    Application.Calculation = originCalculation
    Application.EnableEvents = originEnableEvents
    If Err.Number <> 0 Then MsgBox "执行出错：" & Err.Description, vbCritical
End Sub

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