Combine multiple sheets into summary

[ryland00]

Hello,

I am using the following code and it does not seem to be working. What it is supposed to be doing is taking everything from B12 through BY38 on all of the defined tabs below, and placing them on the summary sheet one after another. I feel like I am missing something relatively easy, but can't figure it out.

Any help would be appreciated.

Sub CopyRangeFromMultiWorksheetsNEW()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

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

    'Set Dest to "Summary"
    Set DestSh = ActiveWorkbook.Sheets("Summary")

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets(Array("APAC", "AM", "EMEA", "INDIA", "LATAM", "CAN"))

            'Find the last row with data on the DestSh
            Last = DestSh.Cells.SpecialCells(xlCellTypeLastCell).Row

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("B12:BY38")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.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
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

    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

 

[Fluff]

I'd suggest changing

 Last = DestSh.Cells.SpecialCells(xlCellTypeLastCell).Row

to

 Last = DestSh.Range("B" & Rows.Count).End(xlUp).Row

As the xlCellTypeLastCell is somewhat flaky.
Other than that what is not working?

 

[mumps]

Try:

Sub CopyRangeFromMultiWorksheetsNEW()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set DestSh = ActiveWorkbook.Sheets("Summary")
    For Each sh In Sheets(Array("APAC", "AM", "EMEA", "INDIA", "LATAM", "CAN"))
        Last = DestSh.Range("A" & Rows.Count).End(xlUp).Row
        If Last + 27 > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If
        sh.Range("B12:BY38").Copy
        With DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With
    Next sh
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[ryland00]

Try:

Sub CopyRangeFromMultiWorksheetsNEW()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set DestSh = ActiveWorkbook.Sheets("Summary")
    For Each sh In Sheets(Array("APAC", "AM", "EMEA", "INDIA", "LATAM", "CAN"))
        Last = DestSh.Range("A" & Rows.Count).End(xlUp).Row
        If Last + 27 > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If
        sh.Range("B12:BY38").Copy
        With DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With
    Next sh
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Thanks both, each suggestion made it work. Thanks for your help!

 

[Fluff]

Glad we could help & thanks for the feedback