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

D

Dan

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
 
D

Dave Peterson

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.
 
D

Dave Peterson

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

Dave said:
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.
Click to expand...
 
D

Dan

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 said:
ps. This wasn't tested and wasn't compiled.
Click to expand...
 
D

Dave Peterson

Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long
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
Click to expand...
 
D

Dana DeLouis

If ws.Name = "Kristine" Or _

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>
 
D

Dan

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 said:
Typing error!!!!!

change:
Dim LastRow As Range
to
Dim LastRow As Long
Click to expand...
 
D

Dave Peterson

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?


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.
Click to expand...
 
D

Dan

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

Dave Peterson

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
Instead of starting at the bottom of Column A, is there a way for it to start
at Row 46?
Click to expand...
 
D

Dan

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
 
D

Dave Peterson

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

If the worksheet name worked ok, then this should???
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
Click to expand...
 
D

Dan

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
 
D

Dave Peterson

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
Click to expand...

It looks like the comments are reversed.
 
D

Dan

Thanks for that catch.


Dave Peterson said:
Glad you got it working.

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


It looks like the comments are reversed.
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Pasting values on first blank row 4
Looping through multiple sheets and pasting data in first blank ro 1
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Referencing two types of sheets - I get Error HELP!! 5
Append Worksheet name to each begining of each row with values 2
Problem with deleting blank rows or last row 4
Find the correct sheet then find a value on that sheet 8
My Macro is slower than the turtle 1

Top