Splitting rows into number of rows based on quantity in a cell

[youdik77]

Hello, I have this peculiar situation I am trying to solve.

I have an extract which contains a list of products and to compare this with another spread sheet I need the quantities for each line to be equal to one.

So I am trying to figure out a macro that would take the row and split it into the same same amount of rows based on quantity in column E (and also make total in column G equal to product value in column F). All other data from the original row would be unchanged.

	A	B	C	D	E	F	G	H	I	J
1
2	CLAIM EXTRACT
3
4	Data	Date 1	Data	Product	Quantity	Product value	Total	Data	Data	Data
5	aaa	15-May-17	ccc	Snake	3	£15.00	£45.00	hhh	iii	jjj
6	aaa	15-May-17	ccc	Hedgehog	1	£20.00	£20.00	hhh	iii	jjj
7	aaa	15-May-17	ccc	Mouse	2	£25.00	£50.00	hhh	iii	jjj
	A	B	C	D	E	F	G	H	I	J
1
2	CLAIM EXTRACT AFTER MACRO
3
4	Data	Date 1	Data	Product	Quantity	Product value	Total	Data	Data	Data
5	aaa	15-May-17	ccc	Snake	1	£15.00	£15.00	hhh	iii	jjj
6	aaa	15-May-17	ccc	Snake	1	£15.00	£15.00	hhh	iii	jjj
7	aaa	15-May-17	ccc	Snake	1	£15.00	£15.00	hhh	iii	jjj
8	aaa	15-May-17	ccc	Hedgehog	1	£20.00	£20.00	hhh	iii	jjj
9	aaa	15-May-17	ccc	Mouse	1	£25.00	£25.00	hhh	iii	jjj
10	aaa	15-May-17	ccc	Mouse	1	£25.00	£25.00	hhh	iii	jjj

<tbody>
</tbody><colgroup><col><col><col><col><col><col><col><col><col><col><col></colgroup>

Any tips, references, ideas would be much appreciated. Whereas I am fairly skilled in Excel analysis, I am an VBA beginner and I am trying to learn as much as possible.

 

[Fluff]

Hia
Give this a go

Sub InsertRows()

    Dim i As Long
    Dim UsdRws As Long
    Dim XtraRws As Integer
    
    Application.ScreenUpdating = False
    
    UsdRws = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = UsdRws To 5 Step -1
        XtraRws = Range("E" & i)
        If XtraRws > 1 Then
            Range("E" & i) = 1
            Range("G" & i) = Range("F" & i)
            Rows(i).Copy
            Rows(i + 1).Resize(XtraRws - 1).Insert
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[youdik77]

Great stuff, thank you.

 

[Fluff]

Glad to help & thanks for the feedback