将值从多个 sheet 复制到一个 sheet

Question

正在尝试找到一种简化的方法来完成以下代码...

将两个不同 sheet 上多个不同单元格的单元格值复制并粘贴到另一个 sheet 到下一个可用行...

代码的第二部分工作得很好......一旦建立了一行，并且 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

同时考虑为您的工作表创建一些变量以避免重复。

将值从多个 sheet 复制到一个 sheet

Copy values from multiple sheets to one sheet

excel

vba

copy-paste