将多个工作表中的值复制到一个工作表中

Question

试图找到一种简化的方式来完成下面的代码...

将单元格值从两个不同工作表上的几个不同单元格复制并粘贴到另一个工作表到下一个可用行...

代码的第二部分工作great...once一个行是建立的，而RW变量标识行号，它将更新很好。

问题出在最初的复制粘贴。代码可以工作，但运行起来非常非常慢。寻找另一种方法来完成同样的事情，运行速度更快，更干净。

    Private Sub CommandButton1_Click()
    Dim response As Integer
    Dim lkup As String
    Dim SourceWS    As Worksheet, DestWS As Worksheet
    Dim SourceRng   As Range, DestCell   As Range
    Dim lloop As Long
    Set SourceWS = Sheets("Leave Calculations") ' Source Sheet
    Set DestWS = Sheets("Historical") 'Destination Sheet
    lkup = Sheets("Formulas").Range("V5").Value


response = MsgBox("Are you ready to print?", vbYesNo, "PRINT SHEET?")

If response = 6 Then

Application.Dialogs(xlDialogPrinterSetup).Show

ActiveSheet.PrintOut

On Error Resume Next
With Sheets("historical")
    Dim Rw2 As Long, Fnd2 As Range
Set Fnd2 = .Range("B:B").Find(lkup, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
 If Not Fnd2 Is Nothing Then
     Rw2 = Fnd2.Row
 'Else
     'MsgBox lkup & " not found in Historical Data"
 End If
             If Rw2 = 0 Then


        ' Copy data to Historical form


        Application.ScreenUpdating = 0


            With SourceWS
            Set DestCell = DestWS.Range("a" & Rows.Count).End(xlUp).Offset(1)
            For lloop = 1 To 30 ' number must match total cells in range
                Set SourceRng = Choose(lloop, Sheets("Formulas").Range("v4"), Sheets("Formulas").Range("v5"), Sheets("Formulas").Range("v2"), Sheets("Leave Calculations").Range("b6"), _
                Sheets("Leave Calculations").Range("c6"), Sheets("Leave Calculations").Range("d6"), Sheets("Leave Calculations").Range("d11"), Sheets("Formulas").Range("v3"), _
                Sheets("Leave Calculations").Range("e15"), Sheets("Leave Calculations").Range("e16"), Sheets("Leave Calculations").Range("e21"), _
                Sheets("Formulas").Range("b39"), Sheets("Formulas").Range("b57"), Sheets("Formulas").Range("c57"), Sheets("Formulas").Range("V10"), _
                Sheets("Formulas").Range("B1"), Sheets("Formulas").Range("B9"), Sheets("Formulas").Range("B10"), Sheets("Formulas").Range("V22"), _
                Sheets("Formulas").Range("V15"), Sheets("Formulas").Range("V16"), Sheets("Formulas").Range("V17"), Sheets("Formulas").Range("V18"), _
                Sheets("Formulas").Range("V19"), Sheets("Formulas").Range("A2"), Sheets("Formulas").Range("V20"), Sheets("Formulas").Range("A2"), Sheets("Formulas").Range("A2"), _
                Sheets("Formulas").Range("B58"), Sheets("Formulas").Range("v21"), Sheets("Formulas").Range("A2"), Sheets("Formulas").Range("v23")) 'adjust the range
                SourceRng.Copy
                DestCell.Offset(, lloop - 1).PasteSpecial xlPasteValues
            Next lloop
            End With

                With Application
                    .CutCopyMode = 0
                    .ScreenUpdating = 0
                End With
     Else:

Answer 1

您可以收集数组中的所有值，然后在完成输入范围的循环时赋值，而不是一个单元格一个单元格地粘贴。

Const NUM_VALS as Long  = 30

dim vals() '<< array for your data

With SourceWS
        Set DestCell = DestWS.Range("a" & Rows.Count).End(xlUp).Offset(1)
        Redim vals(1 to 1, 1 to NUM_VALS)

        For lloop = 1 To NUM_VALS  ' number must match total cells in range

            Set SourceRng = Choose(lloop, Sheets("Formulas").Range("v4"), Sheets("Formulas").Range("v5"), Sheets("Formulas").Range("v2"), Sheets("Leave Calculations").Range("b6"), _
            Sheets("Leave Calculations").Range("c6"), Sheets("Leave Calculations").Range("d6"), Sheets("Leave Calculations").Range("d11"), Sheets("Formulas").Range("v3"), _
            Sheets("Leave Calculations").Range("e15"), Sheets("Leave Calculations").Range("e16"), Sheets("Leave Calculations").Range("e21"), _
            Sheets("Formulas").Range("b39"), Sheets("Formulas").Range("b57"), Sheets("Formulas").Range("c57"), Sheets("Formulas").Range("V10"), _
            Sheets("Formulas").Range("B1"), Sheets("Formulas").Range("B9"), Sheets("Formulas").Range("B10"), Sheets("Formulas").Range("V22"), _
            Sheets("Formulas").Range("V15"), Sheets("Formulas").Range("V16"), Sheets("Formulas").Range("V17"), Sheets("Formulas").Range("V18"), _
            Sheets("Formulas").Range("V19"), Sheets("Formulas").Range("A2"), Sheets("Formulas").Range("V20"), Sheets("Formulas").Range("A2"), Sheets("Formulas").Range("A2"), _
            Sheets("Formulas").Range("B58"), Sheets("Formulas").Range("v21"), Sheets("Formulas").Range("A2"), Sheets("Formulas").Range("v23")) 'adjust the range

            vals(1, lloop) = SourceRng.Value '<< add value to array


        Next lloop
        DestCell.Resize(1, NUM_VALS).Value = vals '<< assign the array
 End With

还可以考虑为您的工作表创建一些变量，以避免所有这些重复。