Change macro to copy variable amount of rows instead of just 1?
 

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

Change macro to copy variable amount of rows instead of just 1?
 

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub


I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1?
 

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
..Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan



"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

If ws.Name = "Kristine" Or _

ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _ etc...


Hi. I see you have an excellent solution. Using Select Case might be another option to use.

Select Case ws.Name
Case "Amy", "Carl", "Dan", "Kristine", "Melanie", "Tamara", "Toby"
'Do Stuff
'etc
End Select

--
Dana DeLouis

<snip

Change macro to copy variable amount of rows instead of just 1
 

No more errors - but now the macro seems to be copying almost the entire
sheet instead of just the rows between 6-46 with text in column A. I see
where it is doing it but I am not sure how to fix it at this point.



"Dave Peterson" wrote:

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

This line:

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

determines the lastrow to copy by starting at the bottom of column A and looking
up to find the last used cell in column A.

Is that ok? Should it be a different column?



Dan wrote:

No more errors - but now the macro seems to be copying almost the entire
sheet instead of just the rows between 6-46 with text in column A. I see
where it is doing it but I am not sure how to fix it at this point.

"Dave Peterson" wrote:

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

Instead of starting at the bottom of Column A, is there a way for it to start
at Row 46?



"Dave Peterson" wrote:

This line:

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

determines the lastrow to copy by starting at the bottom of column A and looking
up to find the last used cell in column A.

Is that ok? Should it be a different column?



Dan wrote:

No more errors - but now the macro seems to be copying almost the entire
sheet instead of just the rows between 6-46 with text in column A. I see
where it is doing it but I am not sure how to fix it at this point.

"Dave Peterson" wrote:

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

Replace this:

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

with:

With ws
If IsEmpty(.Range("B46").Value) = False Then
LastRow = 46
Else
LastRow = .Range("b46").End(xlUp).Row
End If
HowManyRows = LastRow - 6 + 1
End With

Dan wrote:

Instead of starting at the bottom of Column A, is there a way for it to start
at Row 46?

"Dave Peterson" wrote:

This line:

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

determines the lastrow to copy by starting at the bottom of column A and looking
up to find the last used cell in column A.

Is that ok? Should it be a different column?



Dan wrote:

No more errors - but now the macro seems to be copying almost the entire
sheet instead of just the rows between 6-46 with text in column A. I see
where it is doing it but I am not sure how to fix it at this point.

"Dave Peterson" wrote:

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

That's great - there is just one last thing that I can't get to work. The
date only appears once per sheet (in B2), but I would like it copied multiple
times on the total sheet from each previous individual sheet.

I have tried modifying the date part to:

With ws.Range("B2:B2")
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

and also tried:

With ws.Range("B2")
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

but neither work. Do you know what I need to change in order for it to copy
the date from B2 once for each row it finds on that sheet?

Thank you so much for your help again!
-Dan


"Dave Peterson" wrote:

Replace this:

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

with:

With ws
If IsEmpty(.Range("B46").Value) = False Then
LastRow = 46
Else
LastRow = .Range("b46").End(xlUp).Row
End If
HowManyRows = LastRow - 6 + 1
End With

Dan wrote:

Instead of starting at the bottom of Column A, is there a way for it to start
at Row 46?

"Dave Peterson" wrote:

This line:

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

determines the lastrow to copy by starting at the bottom of column A and looking
up to find the last used cell in column A.

Is that ok? Should it be a different column?



Dan wrote:

No more errors - but now the macro seems to be copying almost the entire
sheet instead of just the rows between 6-46 with text in column A. I see
where it is doing it but I am not sure how to fix it at this point.

"Dave Peterson" wrote:

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

rdate.resize(howmanyrows,1).value = ws.range("B2").value
(still untested)

If the worksheet name worked ok, then this should???

Dan wrote:

That's great - there is just one last thing that I can't get to work. The
date only appears once per sheet (in B2), but I would like it copied multiple
times on the total sheet from each previous individual sheet.

I have tried modifying the date part to:

With ws.Range("B2:B2")
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

and also tried:

With ws.Range("B2")
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

but neither work. Do you know what I need to change in order for it to copy
the date from B2 once for each row it finds on that sheet?

Thank you so much for your help again!
-Dan

"Dave Peterson" wrote:

Replace this:

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

with:

With ws
If IsEmpty(.Range("B46").Value) = False Then
LastRow = 46
Else
LastRow = .Range("b46").End(xlUp).Row
End If
HowManyRows = LastRow - 6 + 1
End With

Dan wrote:

Instead of starting at the bottom of Column A, is there a way for it to start
at Row 46?

"Dave Peterson" wrote:

This line:

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

determines the lastrow to copy by starting at the bottom of column A and looking
up to find the last used cell in column A.

Is that ok? Should it be a different column?



Dan wrote:

No more errors - but now the macro seems to be copying almost the entire
sheet instead of just the rows between 6-46 with text in column A. I see
where it is doing it but I am not sure how to fix it at this point.

"Dave Peterson" wrote:

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long

Dan wrote:

Hi Dave,

Thanks for your help. I am getting a Run-time error 91 at "LastRow =
.Cells(.Rows.Count, "A").End(xlUp).Row". It is saying "Object variable or
With block variable not set" - do you know what could be causing that?

Thanks!
-Dan

"Dave Peterson" wrote:

ps. This wasn't tested and wasn't compiled.

Dave Peterson wrote:

Maybe...

Option Explicit
Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Range
Dim HowManyRows As Long

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
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
HowManyRows = LastRow - 6 + 1
End With

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

'Paste date
With ws.Range("B2:b" & LastRow)
rDate.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rDate = rDate.Offset(.Rows.Count, 0)
End With

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

I used column A to determine the last row to copy.

Dan wrote:

Hi,

I am trying to alter the following macro to change the number of rows that
it copies from 1 to a variable number based on what rows have data. Right now
it copies and pastes Rows A, B, and I for row 6. I would like to have it copy
and paste those same values but for all rows that contain data from Row 6-46.

Does anyone know how to make that happen? I have been trying a lot of
different things and searching but nothing seems to be working quite
correctly. I am so close to getting it to work now.

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 = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" 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

--

Dave Peterson

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson


--

Dave Peterson


--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

I was actually able to get it work. My code is below incase it helps anyone
else.

There are just 2 more things, Dave, that is see now - but they are outside
the scope of my original question so I understand if you can't help me with
them:

1) If a sheet contains no data, the macro fails.

2) If I run the macro a 2nd time, it just replaces all of my first data on
the Totals sheet. Is there a way to have it copy the next "run" on the first
blank row below the data?

Thanks again for all your help - this is great!

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

Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Long
Dim HowManyRows As Long

Set rDest = ActiveWorkbook.Worksheets("Totals").Range("C5")
Set rDate = ActiveWorkbook.Worksheets("Totals").Range("B2")
Set rHours = ActiveWorkbook.Worksheets("Totals").Range("E5")

For Each ws In ActiveWorkbook.Worksheets
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
If IsEmpty(.Range("A46").Value) = False Then
LastRow = 46
Else
LastRow = .Range("A46").End(xlUp).Row
End If
HowManyRows = LastRow - 6 + 1
End With

'Paste worksheet name (person)
rDest.Offset(0, -1).Resize(HowManyRows).Value = rDate.Value

'Paste date
rDest.Offset(0, -2).Resize(HowManyRows).Value = ws.Name

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

Change macro to copy variable amount of rows instead of just 1
 

Glad you got it working.

But there seems to be a minor mismatch (unimportant to the code--maybe confusing
to a human):

'Paste worksheet name (person)
rDest.Offset(0, -1).Resize(HowManyRows).Value = rDate.Value

'Paste date
rDest.Offset(0, -2).Resize(HowManyRows).Value = ws.Name

It looks like the comments are reversed.

Dan wrote:

I was actually able to get it work. My code is below incase it helps anyone
else.

There are just 2 more things, Dave, that is see now - but they are outside
the scope of my original question so I understand if you can't help me with
them:

1) If a sheet contains no data, the macro fails.

2) If I run the macro a 2nd time, it just replaces all of my first data on
the Totals sheet. Is there a way to have it copy the next "run" on the first
blank row below the data?

Thanks again for all your help - this is great!

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

Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Long
Dim HowManyRows As Long

Set rDest = ActiveWorkbook.Worksheets("Totals").Range("C5")
Set rDate = ActiveWorkbook.Worksheets("Totals").Range("B2")
Set rHours = ActiveWorkbook.Worksheets("Totals").Range("E5")

For Each ws In ActiveWorkbook.Worksheets
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
If IsEmpty(.Range("A46").Value) = False Then
LastRow = 46
Else
LastRow = .Range("A46").End(xlUp).Row
End If
HowManyRows = LastRow - 6 + 1
End With

'Paste worksheet name (person)
rDest.Offset(0, -1).Resize(HowManyRows).Value = rDate.Value

'Paste date
rDest.Offset(0, -2).Resize(HowManyRows).Value = ws.Name

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

--

Dave Peterson

Change macro to copy variable amount of rows instead of just 1
 

Thanks for that catch.


"Dave Peterson" wrote:

Glad you got it working.

But there seems to be a minor mismatch (unimportant to the code--maybe confusing
to a human):

'Paste worksheet name (person)
rDest.Offset(0, -1).Resize(HowManyRows).Value = rDate.Value

'Paste date
rDest.Offset(0, -2).Resize(HowManyRows).Value = ws.Name

It looks like the comments are reversed.

Dan wrote:

I was actually able to get it work. My code is below incase it helps anyone
else.

There are just 2 more things, Dave, that is see now - but they are outside
the scope of my original question so I understand if you can't help me with
them:

1) If a sheet contains no data, the macro fails.

2) If I run the macro a 2nd time, it just replaces all of my first data on
the Totals sheet. Is there a way to have it copy the next "run" on the first
blank row below the data?

Thanks again for all your help - this is great!

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

Sub Starting()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Dim rDate As Range
Dim rHours As Range
Dim LastRow As Long
Dim HowManyRows As Long

Set rDest = ActiveWorkbook.Worksheets("Totals").Range("C5")
Set rDate = ActiveWorkbook.Worksheets("Totals").Range("B2")
Set rHours = ActiveWorkbook.Worksheets("Totals").Range("E5")

For Each ws In ActiveWorkbook.Worksheets
'Define worksheets to loop through
If ws.Name = "Kristine" Or _
ws.Name = "Toby" Or _
ws.Name = "Carl" Or _
ws.Name = "Tamara" Or _
ws.Name = "Melanie" Or _
ws.Name = "Amy" Or _
ws.Name = "Dan" Then

With ws
If IsEmpty(.Range("A46").Value) = False Then
LastRow = 46
Else
LastRow = .Range("A46").End(xlUp).Row
End If
HowManyRows = LastRow - 6 + 1
End With

'Paste worksheet name (person)
rDest.Offset(0, -1).Resize(HowManyRows).Value = rDate.Value

'Paste date
rDest.Offset(0, -2).Resize(HowManyRows).Value = ws.Name

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

'Paste hours
With ws.Range("I6:I" & LastRow)
rHours.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set rHours = rHours.Offset(.Rows.Count, 0)
End With

End If

Next ws

End Sub

--

Dave Peterson