How to copy multiple worksheets into a summary page but not merge the data.

Question

Let me start by saying I know nothing of VB code in respect to actual programming, I'm trying to help out a friend with a workbook in Excel 2010. I did some Google searching and found what I thought might work for them, but it seems to not be grabbing everything and pasting it into the summary sheet like I want it to.

What I want is to take a set range of cells from each worksheet, copy it, and past it into a summary sheet, when it pasts the data I want it to past that range from sheet 2, move down a line past the same range from sheet 3, and so forth, instead of merging all that data into the same cells, like it seems to be doing now.

Here's the code I'm working with currently, when i use it it seams to only grab the last sheets data, and past it over the top of the previous sheets, instead of pasting then moving down, then pasting the next sheet of data.

Thanks for the help!

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

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

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Summary Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Sheet"

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then

        ' Find the last row with data on the summary worksheet.
        Last = 0

        ' Specify the range to place the data.
        Set CopyRng = sh.UsedRange

        ' Test to see whether there are enough rows in the summary
        ' worksheet to copy all the data.
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the " & _
               "summary worksheet to place the data."
            GoTo ExitTheSub
        End If

        ' This statement copies values and formats from each
        ' worksheet.
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = True
        End With

        ' Optional: This statement will copy the sheet
        ' name in the H column.
        'DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

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

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

Jimmy Smith Jimmy Smith · Accepted Answer · 2014-04-09T14:44:04

Your paste is reverting to row 1 on each pass due to

Last = 0

For the overlapping data, try the following change,

' Find the last row with data on the summary worksheet.
Last = DestSh.Rows.Count + 1

How to copy multiple worksheets into a summary page but not merge the data.

1 Answers