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

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,446
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,170
Office Version
  1. 365
Platform
  1. Windows
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>
 

Watch MrExcel Video

Forum statistics

Threads
1,133,274
Messages
5,657,780
Members
418,413
Latest member
Radoslaw Poprawski

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
Top