Excel VBA to insert rows based on cell value and copy columns based on this number

Question

I know that there are several questions and answers about using Excel VBA to copy and paste rows based on cell value, but I have an additional requirement that makes it difficult to find a solution. I am stuck at this point and need help.

I have a spreadsheet on the following lines:

Name    Unit    Count   Req1    Req2    Req3    Req4    ...  ...    Req25
Apple   304     5       Apple1  Apple2  Apple3  Apple4  ... Apple5  
Pear    562     2       Pear1   Pear2                   
Kiwi    471     4       Kiwi1   Kiwi2   Kiwi3   Kiwi4           

The table has columns for "Req1" through "Req25". If "count" is 5, then "Req1" through the "Req5" columns will have data. The “score” will change depending on the row, leaving a reminder of the “Empty” columns. I need to insert rows based on "count" -1, copy all the columns to the column "count", and then move "Req2", "Req3", etc. To the corresponding inserted row in the column "Req1". I probably don't explain it very well.

I need the final result:

Name    Unit    Count   Req1
Apple   304     5       Apple1
Apple   304     5       Apple2
Apple   304     5       Apple3
Apple   304     5       Apple4
Apple   304     5       Apple5
Pear    562     2       Pear1
Pear    562     2       Pear2
Kiwi    471     4       Kiwi1
Kiwi    471     4       Kiwi2
Kiwi    471     4       Kiwi3
Kiwi    471     4       Kiwi4

I can insert the correct number of rows, but I looped through the loops through the columns and moved them to the "Req1" column.

Any help is POSSIBLE! Thanks in advance!

Answer 1

, , , , ; .

Dim mOut As Worksheet
Dim mInp As Worksheet
Dim num As Integer
Dim i As Integer
Dim j As Integer
Dim c As Integer

Sub Copy()

Set mInp = Worksheets("Your Sheet Name")
Set mOut = Worksheets("Create Another Sheet for Output")

mOut.Cells(1, 1) = mInp.Cells(1, 1)
mOut.Cells(1, 2) = mInp.Cells(1, 2)
mOut.Cells(1, 3) = mInp.Cells(1, 3)
mOut.Cells(1, 4) = "Req"

i = 2
num = 2

While mInp.Cells(i, 1) <> ""
c = mInp.Cells(i, 3)

For j = 1 To c

mOut.Cells(num, 1) = mInp.Cells(i, 1)
mOut.Cells(num, 2) = mInp.Cells(i, 2)
mOut.Cells(num, 3) = mInp.Cells(i, 3)
mOut.Cells(num, 4) = mInp.Cells(i, j + 3)

num = num + 1
Next j

i = i + 1
Wend

End Sub

, , , . , . , , , , .

 For i = 2 To NumRows 'Number of rows (Sum of the inserted and original rows)
         If mInp.Cells(i, 1) <> "" Then

             irow = i
             Count = 1

         Else

             mInp.Cells(i, 1) = mInp.Cells(irow, 1)
             mInp.Cells(i, 2) = mInp.Cells(irow, 2)
             mInp.Cells(i, 3) = mInp.Cells(irow, 3)
             mInp.Cells(i, 4) = mInp.Cells(irow, 4 + Count)

             Count = Count + 1

         End If
 Next i  

Answer 2

Application.Index()

Sub main()
    Dim data1 As Variant, data2 As Variant
    Dim i As Long

    With Range("A2", Cells(Rows.Count, "A").End(xlUp))
        data1 = .Resize(, 3).Value
        data2 = .Offset(, 3).Resize(, 25).Value
        .Resize(, 28).ClearContents
    End With
    For i = LBound(data1) To UBound(data1)
        With Cells(Rows.Count, 1).End(xlUp).Offset(1)
            .Resize(data1(i, 3), 3) = Application.Index(data1, i, 0)
            .Offset(, 3).Resize(data1(i, 3), 1) = Application.Transpose(Application.Index(data2, i, 0))
        End With
    Next
End Sub