执行时间（非相邻单元格的选择、复制和粘贴顺序相同）

Question

这个 VBA 需要很多时间来执行

Sub test()
    Dim IB As String
    Dim copyRng As Range, cel As Range, pasteRng As Range
    
    With Selection
        Set copyRng = Selection
    End With
    
    IB = Application.InputBox("Enter Exact Sheet Name to Paste")
    
    Set pasteRng = Sheets(IB).Range("A1")
    
    For Each cel In copyRng
        cel.Copy
        pasteRng.Range(cel.Address).PasteSpecial xlPasteAll
    Next
    Application.CutCopyMode = False
End Sub

Answer 1

复制非连续范围

• 我已经关闭了屏幕更新，并用循环遍历范围的区域替换了循环遍历单元格。

• 当您只需要复制值时，性能的另一个（巨大）改进将是通过 assignment 复制。 然后在循环中，您将使用以下代码：

   darg.Value = sarg.Value

  而不是sarg.Copy darg 。

Option Explicit

Sub CopyNonContiguous()
    Const ProcTitle As String = "Copy Non-Contiguous"
    
    Dim srg As Range
    If TypeName(Selection) = "Range" Then
        Set srg = Selection
    Else
        MsgBox "Select a range. please.", vbCritical, ProcTitle
        Exit Sub
    End If
    
    Dim wsName As Variant
    wsName = Application.InputBox( _
        "Enter Sheet Name to Paste", ProcTitle, , , , , , 2)
    If wsName = False Then
        MsgBox "You canceled.", vbExclamation, ProcTitle
        Exit Sub
    End If
    
    Dim dws As Worksheet
    On Error Resume Next
    Set dws = ActiveWorkbook.Worksheets(wsName) ' consider 'ThisWorkbook'
    On Error GoTo 0
    If dws Is Nothing Then
        MsgBox "The worksheet '" & wsName & "' doesn't exist.", _
            vbCritical, ProcTitle
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
        
    Dim sarg As Range
    Dim darg As Range
        
    For Each sarg In srg.Areas
        Set darg = dws.Range(sarg.Address)
        sarg.Copy darg
    Next sarg

    Application.ScreenUpdating = True

    MsgBox "Cells copied.", vbInformation, ProcTitle

End Sub