如何减少以下VB代码的时序

Question

For i = 1 To 200
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Change Add Remove Contact Info").Range("B2").Copy Destination:=Sheets("Working").Range("A1")
Sheets("Change Add Remove Contact Info").Range("C7").Copy Destination:=Sheets("Working").Range("B1")
Sheets("Change Add Remove Contact Info").Range("C10").Copy Destination:=Sheets("Working").Range("C1")
Sheets("Change Add Remove Contact Info").Range("C11").Copy Destination:=Sheets("Working").Range("D1")
Sheets("Change Add Remove Contact Info").Range("C12").Copy Destination:=Sheets("Working").Range("E1")
Sheets("Change Add Remove Contact Info").Range("C13").Copy Destination:=Sheets("Working").Range("F1")
Sheets("Change Add Remove Contact Info").Range("C14").Copy Destination:=Sheets("Working").Range("G1")
Sheets("Change Add Remove Contact Info").Range("D17").Copy Destination:=Sheets("Working").Range("H1")
Sheets("Change Add Remove Contact Info").Range("C20").Copy Destination:=Sheets("Working").Range("I1")
Sheets("Change Add Remove Contact Info").Range("C21").Copy Destination:=Sheets("Working").Range("J1")
Sheets("Change Add Remove Contact Info").Range("C22").Copy Destination:=Sheets("Working").Range("K1")
Sheets("working").Range("A1:K1").Copy
Sheets("Data").Range("A" & rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Change Add Remove Contact Info").Range("A:F").EntireColumn.Delete
Sheets("Data").Select
Range("A1").Select
Application.ScreenUpdating = False
Next i

我正在尝试将多个单元格从一个表格复制粘贴到另一个电子表格。但宏需要大量时间来运行后台。

Answer 1

试试这个代码：

Sub TestCopy()
    Dim src As Worksheet, dest As Worksheet
    Set src = Sheets("Change Add Remove Contact Info")
    Set dest = Sheets("Data")
    
    Dim A As Variant, rng As Range
    Set rng = src.Range("B2,C7,C10:C14,D17,C20:C22")
    ReDim A(1 To rng.Count)
    
    Dim last As Long
    last = dest.Range("A" & Rows.Count).End(xlUp).Row
    
    Dim B As Variant
    ReDim B(1 To 200)
    Dim i As Long, j As Long, c As Range
    For i = 1 To 200
        If i > 1 Then Set rng = rng.Offset(, 6)
        j = 0
        For Each c In rng
            j = j + 1
            A(j) = c.Value
        Next c
        B(i) = A
    Next i
    dest.Range("A" & last + 1).Resize(200, rng.Count) = Application.Index(B, 0)
End Sub