執行時間（非相鄰單元格的選擇、復制和粘貼順序相同）

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