Complex copy and paste looping VBA help

[Dan]

Hi,
I have been searching a lot for what I want to do and so far can do some of
the individual components, but am not sure how to put it all together. I will
try to explain what I am trying to do as best as I can. Please let me know if
it is confusing.

-Workbook has 7 sheets (6 individual and 1 summary sheet)

I am trying to write a macro which will:
-Loop through all individual sheets, copying cell values to the Totals sheet
-Perform these actions on each individual sheet:
--Locate every row where Column I contains a number > 0
--Copy values from that row in Columns A, B, I
--Go to first blank row in Totals sheet (there should be no gaps if using
Column B to look for values)
--Paste values using the following mapping: Individual!B1 should always be
Totals column A, Individual!B2 should always be Totals column B, Individual A
-> Totals C, Individual B -> Totals D, Individual I -> Totals E
--Repeat for every row in Individual that has data in Column A between rows
6 and the first gap

-Loop through all six individual sheets (named Toby, Kristine, Carl, Amy,
Dan, Tamara), performing the actions above and always copy the cell values to
the first blank row in Totals, starting at Row 5.

I know this is a huge project and I have probably not explained it very well
but I would really appreciate any help anyone could offer me. I can provide
screen shots, or the file if that would help anyone.

Thank you!
-Dan

 

[ryguy7272]

This code WON'T do everything that you want, but should get you started in
the right direction:

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range

Set rDest = ActiveWorkbook.Worksheets("Summary").Range("B3")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Summary" Then
rDest.Offset(0, -1).Value = ws.Name
With ws.Range("B39:T39") '< -- change range...
rDest.Resize(1, .Columns.Count).Value = .Value
End With
Set rDest = rDest.Offset(1, 0)
End If
Next ws

Change the ranges to suit your needs.

Regards,
Ryan---

 

[Dan]

Hi Ryan,

Thanks for your help. It was a great start and it works good right now. I'm
just having a couple problems I'm hoping you can help me with (my code is
below):

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.

Thank you!
-Dan

 

[Dan]

Sorry - forgot to attach my code so far:

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

 

[Dan]

Hi Ryan,

Is there any chance you could take a look at my code above?

Thanks,
-Dan