将范围从一张纸复制到另一张纸并粘贴多次，直到循环到下一张纸为止

Question

我正在尝试从多个工作表复制单元格A3，B4和C2，以粘贴到主工作表范围A：C中。以及从多张纸到主纸范围D：F的单元格A8至C25。

我已将所有单元格复制到主表中所需的目标位置的代码。但是，由于D：F有多行，因此导致A：C中的单元格为空。请参阅copyrng4。

目前，我有以下代码可用于复制：

For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name And sh.Name <> "Main" And sh.Name <> "Master" Then

        'Find the last row with data on the DestSh
        Last = LastRow(DestSh)

        'Fill in the range that you want to copy
        Set CopyRng1 = sh.Range("A3")
        Set CopyRng2 = sh.Range("B4")
        Set CopyRng3 = sh.Range("C2")
        Set CopyRng4 = sh.Range("A8:C25")

        'Test if there enough rows in the DestSh to copy all the data
        If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If

        'This example copies values/formats, if you only want to copy the
        'values or want to copy everything look at the example below this macro
        CopyRng1.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With

        CopyRng2.Copy
        With DestSh.Cells(Last + 1, "B")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With

        CopyRng3.Copy
        With DestSh.Cells(Last + 1, "C")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With   

        CopyRng4.Copy
        With DestSh.Cells(Last + 1, "D")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With

    End If
Next

结果截屏

此代码有效，除了第一个工作表循环。它复制值A1，B1和C1以及Copyrng4值在D1：F18中。它将A2：C18中的所有行留空。

将copyrang4复制到主表上的D1：F18时，是否可以将A1：C1中的值复制到A2：C18中？

我试图将A1：C1中的值复制到下面的任何空白列中，直到循环转到下一页为止。

Answer 1

For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name And sh.Name <> "Main" And sh.Name <> "Master" Then

        'Find the last row with data on the DestSh
        Last = LastRow(DestSh)

        'Test if there enough rows in the DestSh to copy all the data
        If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If

        'fill 3 values down...
        DestSh.Cells(Last + 1, "A").Resize(18, 3).Value = _
            Array(sh.Range("A3").Value, sh.Range("B4").Value, sh.Range("C2").Value)

        sh.Range("A8:C25").Copy
        With DestSh.Cells(Last + 1, "D")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With

    End If
Next