Copy rows to another worksheet a variable number of times

[rgrovier]

If this has been asked, I apologize for having not found it ... I have a spreadsheet with over 1000 rows. I want users to be able to indicate the number of times a row should be duplicated (1-19) and then automatically copy that row the indicated number of times to another worksheet within the same workbook. This process can be done at the end of the user input procedure and I will just add it to a macro that will be run prior to closing out the file. Any help will be greatly appreciated. Thanks.

Example:
Row 1 - 5, is copied 5 times
Row 2 - left blank, is not copied
Row 3 - 1, is copied only once

 

[PeregrinTook]

Hi rgrovier, welcome to the board!

This should hopefully do what you require (as long as my assumtions below are correct!), but perhaps now I've posted it someone may be able to help in refining the processing time or even just the code. Here's what i came up with...

Assuming you have a header row in row 1 of both sheet1 (source) & sheet2 (destination), and that your data has a value in column A from row 2 through to the last row, and that you want the user to be able to loop through each row in turn - try this:

Sub MyCopy()
Dim iCopyAmount, iCurRow, iSourceLastRow, iPasteCount, iDestRow As Long
Dim strSource, strDest, strTitle, strMessage As String
Dim rngSource, rngDest As Range

strSource = "Sheet1" 'change to suit
strDest = "Sheet2" 'change to suit
iSourceLastRow = Worksheets(strSource).Range("A" & Rows.Count).End(xlUp).Row 'must be a column_
'with continuous data from first to last row, change from "A" if required

For iCurRow = 2 To iSourceLastRow Step 1 'change 2 to first row of data if not correct
    strTitle = "Copy row " & iCurRow 'change to suit
    strMessage = strTitle & " to '" & strDest & "' how many times?" 'change to suit
    Set rngSource = Worksheets(strSource).Rows(iCurRow) 'set range to copy
    rngSource.Activate 'delete if row not required to be highlighted
    Application.ScreenUpdating = False
    iCopyAmount = Application.InputBox(strMessage, strTitle, , , , , , 1) 'define number of copies from input box
    For iPasteCount = 1 To iCopyAmount Step 1 'set number of times to copy starting at 1
        iDestRow = Worksheets(strDest).Range("A" & Rows.Count).End(xlUp).Row + 1 'find paste row
        Set rngDest = Worksheets(strDest).Rows(iDestRow) 'set paste row
        rngSource.Copy rngDest 'do the copy & paste
    Next iPasteCount 'next copy/paste until required number of copies are completed
    Application.ScreenUpdating = True
Next iCurRow 'next row

Worksheets(strSource).Range("A1").Select
MsgBox "All rows have been copied", vbInformation, "Copy Process Complete" 'change to suit
End Sub

Let me know how it goes
All the best
PeregrinTook

 

[rgrovier]

Very cool. Is there any way to eliminate the input message box and have the number of times to paste the record pulled from the value in the first column of the record? That is, from cell A2 for row 2, cell A3 for row 3, etc.?

Thanks for your help,
Reich

 

[PeregrinTook]

Sorry Reich I thought you wanted the 'number of times to copy' choice to come from an input box line by line - try this instead...

Sub MyCopyNoInputBox()
Dim iCopyAmount, iCurRow, iSourceLastRow, iPasteCount, iDestRow As Long
Dim strSource, strDest As String
Dim rngSource, rngDest As Range

strSource = "Sheet4" 'change to suit
strDest = "Sheet5" 'change to suit
iSourceLastRow = Worksheets(strSource).Range("A" & Rows.Count).End(xlUp).Row 'must be a column_
'with continuous data from first to last row, change from "A" if required
Application.ScreenUpdating = False

For iCurRow = 2 To iSourceLastRow Step 1 'change 2 to first row of data if not correct
    Set rngSource = Worksheets(strSource).Rows(iCurRow) 'set range to copy
    iCopyAmount = Worksheets(strSource).Cells(iCurRow, "A").Value 'define number of copies from column "A" of current row
    For iPasteCount = 1 To iCopyAmount Step 1 'set number of times to copy starting at 1
        iDestRow = Worksheets(strDest).Range("A" & Rows.Count).End(xlUp).Row + 1 'find paste row
        Set rngDest = Worksheets(strDest).Rows(iDestRow) 'set paste row
        rngSource.Copy rngDest 'do the copy & paste
    Next iPasteCount 'next copy/paste until required number of copies are completed
Next iCurRow 'next row

Application.ScreenUpdating = True
Worksheets(strSource).Range("A1").Select
MsgBox "All rows have been copied", vbInformation, "Copy Process Complete" 'change to suit
End Sub

All the best
PeregrinTook

 

[rgrovier]

PeregrinTook,

Thank you! It worked but I think I have too much data to make it feasible this way. Perhaps someone will else will know of a way to make it process faster.

In any event, you have convinced me that I need to learn VBA. I've always avoided it until now but as I was deciphering your code (what little I could) I decided that I need to bite the bullet.

Thanks again, Reich

 

[PeregrinTook]

Ok Reich, this time hopefully...

I've removed the second loop (iPasteCount) and defined the paste range as the desired number of rows on sheet2 so it pastes across in one shot now rather than using another loop to paste one row at at time.

Should now be significantly quicker - I tried 1,200 rows of data with random values of 1-19 in col A for each row and it took about a second to complete (generated 11,972 rows on sheet2).

Sub MyCopy()
Dim iCopyAmount, iCurRow, iSourceLastRow, iDestRow As Long
Dim strSource, strDest As String
Dim rngSource, rngDest As Range

strSource = "Sheet1" 'change to suit
strDest = "Sheet2" 'change to suit
iSourceLastRow = Worksheets(strSource).Range("A" & Rows.Count).End(xlUp).Row 'must be a column_
'with continuous data from first to last row, change from "A" if required
Application.ScreenUpdating = False

For iCurRow = 2 To iSourceLastRow Step 1 'change 2 to first row of data if not correct
    Set rngSource = Worksheets(strSource).Rows(iCurRow) 'set range to copy
    iCopyAmount = Worksheets(strSource).Cells(iCurRow, "A").Value 'define number of copies from column "A" of current row
    iDestRow = Worksheets(strDest).Range("A" & Rows.Count).End(xlUp).Row + 1 'find first available paste row
    Set rngDest = Range(Worksheets(strDest).Rows(iDestRow), Worksheets(strDest).Rows(iDestRow + iCopyAmount - 1)) 'set paste range
    rngSource.Copy rngDest 'do the copy & paste
Next iCurRow 'next row

Application.ScreenUpdating = True
Worksheets(strSource).Range("A1").Select
MsgBox "All rows have been copied", vbInformation, "Copy Process Complete" 'change to suit
End Sub

Let me know how you go.

Cheers
PeregrinTook

 

[rgrovier]

Hi,

I feel like I'm being a pest but ... I'm getting a "Run-time error '1004': Method 'Range' of object'_Worksheet' failed" . When I debug, the following code is highlighted:

Set rngDest = Range(Worksheets(strDest).Rows(iDestRow), Worksheets(strDest).Rows(iDestRow + iCopyAmount - 1)) 'set paste range

I've gone through and checked for anything obvious but nothing seems to stand out. I think I understand what it is trying to do but it isn't doing it.

I really do appreciate all of your help on this. Thanks, Reich[/code]

 

[PeregrinTook]

No probs at all Reich, hope we can get this fixed in the end...

"Run-time error '1004': Method 'Range' of object'_Worksheet' failed"

I made the last amendment this morning on my work pc & it worked fine there - just tried it on my home pc and it works fine for me here too, I don't get that error (which makes it a bit more difficult to fix unfortunately!).

I can only suggest two things:

1. I have Option Explicit at the very top of the module so you could try putting that there, but I'm almost positive that'll make no difference as I think that just ensures every variable is Dim'd.

2. Rather than calculating the end paste row within the range statement, I've found excel sometimes prefers only a single variable name in there - so try this slight amendment:

Sub MyCopy2()
Dim iCopyAmount, iCurRow, iSourceLastRow, iDestRow, iDestEndRow As Long
Dim strSource, strDest As String
Dim rngSource, rngDest As Range

strSource = "Sheet1" 'change to suit
strDest = "Sheet2" 'change to suit
iSourceLastRow = Worksheets(strSource).Range("A" & Rows.Count).End(xlUp).Row 'must be a column_
'with continuous data from first to last row, change from "A" if required
Application.ScreenUpdating = False

For iCurRow = 2 To iSourceLastRow Step 1 'change 2 to first row of data if not correct
    Set rngSource = Worksheets(strSource).Rows(iCurRow) 'set range to copy
    iCopyAmount = Worksheets(strSource).Cells(iCurRow, "A").Value 'define number of copies from column "A" of current row
    iDestRow = Worksheets(strDest).Range("A" & Rows.Count).End(xlUp).Row + 1 'find first available paste row
    iDestEndRow = iDestRow + iCopyAmount - 1 'new variable end paste row
    Set rngDest = Range(Worksheets(strDest).Rows(iDestRow), Worksheets(strDest).Rows(iDestEndRow)) 'set paste range
    rngSource.Copy rngDest 'do the copy & paste
Next iCurRow 'next row

Application.ScreenUpdating = True
Worksheets(strSource).Range("A1").Select
MsgBox "All rows have been copied", vbInformation, "Copy Process Complete" 'change to suit
End Sub

Let me know if it makes any difference...

Cheers
PeregrinTook

 

[rgrovier]

PeregrinTook,

Had to re-write a bit of the code you sent to look like this to fix the error:

Set rngDest = Worksheets(strDest).Range(Worksheets(strDest).Rows(iDestRow), Worksheets(strDest).Rows(iDestEndRow)) 'set paste range

Then I had records with zero iCopyAmounts messing up the prior record. So I added an IF-End if Statement to bypass the zeros (probably no big deal to anyone else on the board but pretty significant for me). It now looks like this:

Private Sub CommandButton1_Click()
Dim iCopyAmount, iCurRow, iSourceLastRow, iDestRow, iDestEndRow As Long
Dim strSource, strDest As String
Dim rngSource, rngDest As Range

strSource = "Sheet1" 'change to suit
strDest = "Sheet2" 'change to suit
iSourceLastRow = Worksheets(strSource).Range("F" & Rows.Count).End(xlUp).Row 'must be a column_
'with continuous data from first to last row, change from "F" if required
Application.ScreenUpdating = False

For iCurRow = 5 To iSourceLastRow Step 1 'change 5 to first row of data if not correct
    Set rngSource = Worksheets(strSource).Rows(iCurRow) 'set range to copy
    iCopyAmount = Worksheets(strSource).Cells(iCurRow, "F").Value 'define number of copies from column "F" of current row
    If iCopyAmount > 0 Then
    iDestRow = Worksheets(strDest).Range("F" & Rows.Count).End(xlUp).Row + 1 'find first available paste row
    iDestEndRow = iDestRow + iCopyAmount - 1 'new variable end paste row
    Set rngDest = Worksheets(strDest).Range(Worksheets(strDest).Rows(iDestRow), Worksheets(strDest).Rows(iDestEndRow)) 'set paste range
    rngSource.Copy rngDest 'do the copy & paste
    End If
Next iCurRow 'next row

Application.ScreenUpdating = True
Worksheets(strSource).Range("A1").Select
MsgBox "All rows have been copied", vbInformation, "Copy Process Complete" 'change to suit

End Sub

I'll drop it in my live version tomorrow to test the speed.

While scrolling through documentation I've thought of other things to do with this application. Thanks for all your help.

Best regards and have a good weekend!

Reich

 

[PeregrinTook]

Ah of course, I shoulda noticed - you mentioned in your very first post that 'if the cell is blank make no copies', where I had wrongly assumed zeros would be used. Wasn't quite with it last nite after a few post-work beers...

Strange you need the extra 'worksheets' in front of the range & I don't - wonder why that is... Difference between versions of excel perhaps? I'm using V10 (2002) both at home and work I think...

Glad you got it sorted anyway, that's the main thing - hope it's fast enough for your purposes now though!

All the best
PeregrinTook