Copy data from multiple worksheets into one

[theheed]

Team,

I am looking to copy the entire range of data from several worksheets (or prefereably seperate excel workbooks, if possible) into a single worksheet. Thus giving me one big list.

I had a hunt about for macros and got the following. it works but only pulls the first row from all the sheets then stops.

Cheers Team

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
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
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("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
' 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 = LastRow(DestSh)
' Specify the range to place the data.
Set CopyRng = sh.Rows("1")
' 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 = False
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

 

[sanrv1f]

try this to copy data from all the sheets to a master sheet,

change the Master sheet name and range to copy to your need

Sub Copy_to_Master()

Dim sh1 As Integer, lastrow As Long, ws As Worksheet
sh1 = Worksheets("Master").Index
For Each ws In Worksheets
lastrow = Worksheets(sh1).UsedRange.Rows.Count
If ws.Index <> sh1 Then
    ws.Activate
    Range("D4:J27").Copy
    Worksheets(sh1).Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Application.CutCopyMode = False
End If
Next ws
Worksheets(sh1).Activate
End Sub

 

[theheed]

Excellent. It appears to copy the data formatted as

Header Header Header
data etc
data

To

HEader data data etc
Header
Header

Can we spin it back?

 

[sanrv1f]

just change this line

Worksheets(sh1).Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=False

 

[theheed]

Excellent work!