VBA required to duplicate rows dependant on quantity

[TM74]

Hi,

I'm working on some VBA to re-format some quotations to a more basic layout for data entry. The re-formatted sheet is very simple containing just the product code in column A and the quoted quantity in column B.

A colleague has asked me if the quantities could be ommitted but if the quantity is greater than 1 then it should duplicate the code underneath the original (duplicate once for a quantity of 2 or twice for a quantity of 3 and so on).

I'm not really even sure where to start with this - can anyone help?

 

[kgkev]

Sub createdups()
Dim rng As Range

Set rng = Sheets("input").Range("A2", Sheets("input").Range("A60000").End(xlUp))

For Each Item In rng
    Counter = Item.Offset(, 1).Value
    For RepeatCount = 1 To Counter
        Sheets("output").Range("A60000").End(xlUp).Offset(1).Value = Item.Value
    Next RepeatCount
Next Item


End Sub

Current sheet is called Input - This looks like

Excel Workbook
	A	B
1	Product	Qty
2	PART1	1
3	PART2	5
4	PART3	6
5	PART4	7
6	PART5	5
7	PART6	1
8	PART7	10
9	PART8	5
10	PART9	2
11	PART10	3
12	PART11	1
13	PART12	2
14	PART13	5
15	PART14	6
16	PART15	7
Input

Create a second sheet called Output - then run the code. (copy and paste into a module)

Let me know how it goes.

 

[TM74]

That does look absolutely perfect. Just one problem - which was my fault - I forgot to mention that column B does not contain the quantities! Column C does - column B contains a customer number. I solved this by changing this:

Counter = Item.Offset(, 1).Value

To this:

Counter = Item.Offset(, 2).Value

The only thing I can't work out is how to get the output sheet to contain the values from both column A & B. Could you help with that part?

 

[kgkev]

Sub createdups()
Dim rng As Range

Set rng = Sheets("input").Range("A2", Sheets("input").Range("A60000").End(xlUp))

For Each Item In rng
    Counter = Item.Offset(, 2).Value
    For RepeatCount = 1 To Counter
    With Sheets("output").Range("A60000").End(xlUp).Offset(1)
        .Value = Item.Value
        .Offset(, 1).Value = Item.Offset(, 1).Value
    End With
    Next RepeatCount
Next Item


End Sub

Should work.


Make sure you clear the output sheet before running a second time

 

[TM74]

Fantastic! Thanks a lot.