Inserting new rows based on cell value and copying data to the new rows

[10digwa]

Hi all,

I've been searching for a solution to my issue on the board but could not find a working solution that covers my needs.
I'd really appreciate some help to come up with a VBA code that does the following:

I need to break down a single row of data consisting of multiple columns into separate rows but the same column, similar to a transpose, but not exactly. Some rows contain different amounts of columns/data.
There is also a field, where I can enter a value, and this is the amount of lines that get inserted per cell/column within the row. I hope that makes sense.

I have the below code working as closest as I can to what I want, the only issue is, if row 1 has 8 values in 8 different columns, and row 2 has 6 Values in 6 different columns, then the code thinks there is data in row 2, Column 7 & 8. and creates those extra blank inserts. Is there a way i can remove these extra columns ?

CODE BELOW:

Sub Inert_rows()
Dim r As Long


For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
With Cells(r, 3)
If IsNumeric(.Value) And Not IsEmpty(.Value) Then
Rows(r + 1).Resize(.Value).Insert

Range(Replace("H#", "#", r)).Copy Destination:=Range("D" & r + 1).Resize(.Value)
Range(Replace("I#", "#", r)).Copy Destination:=Range("E" & r + 1).Resize(.Value)
End If
End With
Next r


For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
With Cells(r, 3)
If IsNumeric(.Value) And Not IsEmpty(.Value) Then
Rows(r + 1).Resize(.Value).Insert

Range(Replace("F#", "#", r)).Copy Destination:=Range("D" & r + 1).Resize(.Value)
Range(Replace("G#", "#", r)).Copy Destination:=Range("E" & r + 1).Resize(.Value)
End If
End With
Next r



For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
With Cells(r, 3)
If IsNumeric(.Value) And Not IsEmpty(.Value) Then
Rows(r + 1).Resize(.Value).Insert

Range(Replace("D#", "#", r)).Copy Destination:=Range("D" & r + 1).Resize(.Value)
Range(Replace("E#", "#", r)).Copy Destination:=Range("E" & r + 1).Resize(.Value)
End If
End With
Next r


End Sub

Order 1	2	Order 1 Product 1	1	Order 1 Product 2	1	Order 1 Product 3	1	Order 1 Product 4	1
Order 2	3	Order 2 Product 1	1	Order 2 Product 2	1
Order 3	4	Order 3 Product 1	1	Order 3 Product 2	1