Duplicate each row different number of times

artizhay

New Member
Joined
Jul 22, 2010
Messages
8
Hello! What I'm looking to do is duplicate each row a different number of times (either in the same sheet or a new sheet) so that there end up being x # of instances of each row as defined by column C.

Example:
Excel Workbook
ABC
1Item #ItemCopy
2PRO-CEL-00-BLK2000-2003 Toyota Celica4
3PRO-CEL-03-BLK2003-2005 Toyota Celica3
Beginning


Excel Workbook
ABC
1Item #ItemCopy
2PRO-CEL-00-BLK2000-2003 Toyota Celica4
3PRO-CEL-00-BLK2000-2003 Toyota Celica4
4PRO-CEL-00-BLK2000-2003 Toyota Celica4
5PRO-CEL-00-BLK2000-2003 Toyota Celica4
6PRO-CEL-03-BLK2003-2005 Toyota Celica3
7PRO-CEL-03-BLK2003-2005 Toyota Celica3
8PRO-CEL-03-BLK2003-2005 Toyota Celica3
Result


I have looked up duplication macros and found some that work well, but they duplicated by a set number of times and I need to duplicate various times per row.

Thanks a ton!
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Try this. The 'copies' will go into a new sheet added immediately after the sheet with the original data which I have assumed is 'Sheet1'. Change to match your sheet name.
Code:
Sub MakeCopies()
Dim sRng As Range, sSht As Worksheet, rRng As Range, rSht As Worksheet
Dim sRw As Long, rRw As Long, i As Long, ctr As Long

Set sSht = Sheets("sheet1") 'Enter your sheet name between the quotes
With sSht
    sRw = .Cells(Rows.Count, 1).End(xlUp).Row
End With
Set rSht = Sheets.Add(after:=sSht)
With rSht
    .Range(Cells(1, 1), Cells(1, 3)) = Array("Item #", "Item", "Copy")
End With
For i = 1 To sRw - 1
    ctr = 0
    Do Until ctr >= sSht.Cells(i + 1, 3).Value
        rRw = rSht.Cells(Rows.Count, 1).End(xlUp).Row
        sSht.Activate
        With sSht
         .Range(Cells(i + 1, 1), Cells(i + 1, 2)).Copy Destination:=rSht.Cells(rRw + 1, 1)
        End With
        ctr = ctr + 1
    Loop
Next i

End Sub
 
Upvote 0
You could try this in a copy of your workbook.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> InsertRows()<br>    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, newrows <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    lr = Range("C" & Rows.Count).End(xlUp).Row<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> r = lr <SPAN style="color:#00007F">To</SPAN> 2 <SPAN style="color:#00007F">Step</SPAN> -1<br>        newrows = Range("C" & r).Value - 1<br>        <SPAN style="color:#00007F">If</SPAN> newrows > 0 <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">With</SPAN> Range("A" & r).Resize(, 3)<br>                .Copy<br>                .Offset(1).Resize(newrows).Insert Shift:=xlDown<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> r<br>    Application.CutCopyMode = <SPAN style="color:#00007F">False</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br></FONT>
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,142
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top