Looping through multiple sheets and pasting data in first blank ro
 

I posted this a couple weeks ago but got no response and figured it might
have been lost in the shuffle.

I have 7 sheets in my workbook (6 individuals and 1 summary) and I am
looking to create a macro that will loop through all the individual sheets,
copying cells values to the total sheet. It is a little more complicated as
you will see, but a lot of it is working already.

Right now I am having some trouble though:

1) On the individual worksheets, it only grabs one row, even if there are
multiple ones filled. I would ideally like it to start at A6, and then loop
through, copying from every row until it hits a blank row. Then move onto the
next worksheet.

2) When pasting on the "Totals" worksheet, I would like it to look for the
first blank row after row 5 and then start pasting there. Right now if I run
the macro twice, it will just overwrite whatever it put there the first time.

Any help would be appreciated!

My code so far is below. Thanks!
-Dan

---------------------------------------------------

Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range

Set rDest = ActiveWorkbook.Worksheets("Totals").Range("C5")
Set rDate = ActiveWorkbook.Worksheets("Totals").Range("B5")
Set rHours = ActiveWorkbook.Worksheets("Totals").Range("E5")
For Each ws In ActiveWorkbook.Worksheets

'Defind worksheets to loop through
If ws.Name = "Toby" Or _
ws.Name = "Kristine" Or _
ws.Name = "Carl" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Or _
ws.Name = "Tamara" Then

'Paste worksheet name
rDest.Offset(0, -2).Value = ws.Name

'Paste date
With ws.Range("B2")
rDate.Resize(1, .Columns.Count).Value = .Value
End With
Set rDate = rDate.Offset(1, 0)

'Paste activity and category
With ws.Range("A6:B6")
rDest.Resize(1, .Columns.Count).Value = .Value
End With
Set rDest = rDest.Offset(1, 0)

'Paste hours
With ws.Range("I6")
rHours.Resize(1, .Columns.Count).Value = .Value
End With
Set rHours = rHours.Offset(1, 0)

End If

Next ws

End Sub

Looping through multiple sheets and pasting data in first blank ro
 

Hi Dan

See this page
http://www.rondebruin.nl/copy2.htm

Or my MSDN Article
http://msdn.microsoft.com/en-us/library/cc793964.aspx

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Dan" wrote in message ...
I posted this a couple weeks ago but got no response and figured it might
have been lost in the shuffle.

I have 7 sheets in my workbook (6 individuals and 1 summary) and I am
looking to create a macro that will loop through all the individual sheets,
copying cells values to the total sheet. It is a little more complicated as
you will see, but a lot of it is working already.

Right now I am having some trouble though:

1) On the individual worksheets, it only grabs one row, even if there are
multiple ones filled. I would ideally like it to start at A6, and then loop
through, copying from every row until it hits a blank row. Then move onto the
next worksheet.

2) When pasting on the "Totals" worksheet, I would like it to look for the
first blank row after row 5 and then start pasting there. Right now if I run
the macro twice, it will just overwrite whatever it put there the first time.

Any help would be appreciated!

My code so far is below. Thanks!
-Dan

---------------------------------------------------

Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range

Set rDest = ActiveWorkbook.Worksheets("Totals").Range("C5")
Set rDate = ActiveWorkbook.Worksheets("Totals").Range("B5")
Set rHours = ActiveWorkbook.Worksheets("Totals").Range("E5")
For Each ws In ActiveWorkbook.Worksheets

'Defind worksheets to loop through
If ws.Name = "Toby" Or _
ws.Name = "Kristine" Or _
ws.Name = "Carl" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Or _
ws.Name = "Tamara" Then

'Paste worksheet name
rDest.Offset(0, -2).Value = ws.Name

'Paste date
With ws.Range("B2")
rDate.Resize(1, .Columns.Count).Value = .Value
End With
Set rDate = rDate.Offset(1, 0)

'Paste activity and category
With ws.Range("A6:B6")
rDest.Resize(1, .Columns.Count).Value = .Value
End With
Set rDest = rDest.Offset(1, 0)

'Paste hours
With ws.Range("I6")
rHours.Resize(1, .Columns.Count).Value = .Value
End With
Set rHours = rHours.Offset(1, 0)

End If

Next ws

End Sub