Excel從多張工作表復制不起作用vba

Question

我已將這段代碼組合在一起，以將不同范圍從多個工作表復制到主工作表。 但是對於 copyRng 7，它不是在 copyrng6 之下，而是覆蓋 copyrng6。

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range



With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With


Application.DisplayAlerts = False

Set DestSh = Sheets("Main")


'loop through all worksheets and copy the data to the DestSh
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("B3")
        Set CopyRng2 = sh.Range("C3")
        Set CopyRng3 = sh.Range("D3")
        Set CopyRng4 = sh.Range("G3")
        Set CopyRng5 = sh.Range("C5")
        Set CopyRng6 = sh.Range("A8:j25")
        Set CopyRng7 = sh.Range("A28:j44")

        '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 xlPasteValues
            Application.CutCopyMode = False
        End With
         CopyRng5.Copy
        With DestSh.Cells(Last + 1, "E")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With


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


    End If
Next

 ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

提前致謝。 這是我的第一個問題，對於任何錯誤或混淆，我提前道歉。 如果被問到，我可以提供更多解釋。 謝謝

Answer 1

刷新6到7復制之間的last變量復制6后刷新工作表上新的最后一行：

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

    last = LastRow(DestSh)

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