Copy from Multiple Sheets

[Eric]

I am trying to compile data from multiple worksheets into
a single worksheet. The ranges from the multiple sheet
vary from sheet to sheet. Also, rows in each sheet can be
added or deleted (i.e. the range in a sheet will not
always be the same.)

Does anyone know of code available that will accomplish
this task?

Thanks

 

[Ron de Bruin]

Hi Eric

Try this
http://www.rondebruin.nl/copy2.htm

 

[Eric Byers]

Do you have anything that will copy from only selected sheets. Forgive
me, I'm a VB novice.

Thanks

 

[Ron de Bruin]

Hi Eric

I change the first sub on the page for you.
Add a worksheet to the workbook first with the name "Master"

Copy the sub and the function in a normal module

Sub Test1()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

Application.ScreenUpdating = False
Set DestSh = Worksheets("Master")
For Each sh In ActiveWindow.SelectedSheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)

sh.Range("A1:C5").Copy DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below to copy only the values
'or use the PasteSpecial option to paste the format also.


'With sh.Range("A1:C5")
'DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
'.Columns.Count).Value = .Value
'End With


'sh.Range("A1:C5").Copy
'With DestSh.Cells(Last + 1, "A")
' .PasteSpecial xlPasteValues, , False, False
' .PasteSpecial xlPasteFormats, , False, False
' Application.CutCopyMode = False
'End With

DestSh.Cells(Last + 1, "D").Value = sh.Name
'This will copy the sheet name in the D column if you want

End If
Next
Cells(1).Select
Application.ScreenUpdating = True
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