Copy a range in multiple worksheets into one

[Lizard07]

Greetings. I have been working a loop code to copy a specific range of data in multiple worksheets and move into one summary sheet. Currently, my code is only copying data from the first sheet and I have not been able to figure out how to loop it. Please see code below, any help would be much appreciated!! Thanks!

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("Master").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master"
' 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.
lastrow = Sheets("Master").Range("A65536").End(xlUp).Row
' Specify the range to place the data.
Set CopyRng = sh.Range("A15:H25")
' 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
Application.CutCopyMode = False
End With
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

 

[VoG]

Try

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("Master").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master"
' 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 = Sheets("Master").Range("A65536").End(xlUp).Row
' Specify the range to place the data.
Set CopyRng = sh.Range("A15:H25")
' 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
    Application.CutCopyMode = False
End With
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

 

[Lizard07]

That worked perfectly! Thank-you