Excel VBA基于单元格值插入行，并根据该数字向下复制列

Question

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

I have a spreadsheet along the lines of the following:

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 spreadsheet has columns for "Req1" through "Req25." If the"count" is 5, then "Req1" through "Req5" columns will have data. The "count" will vary per row leaving the reminder of the columns to "Req25" blank. I need to insert rows based on "count" -1, copy down all columns up to "count" column, and then move "Req2," "Req3," etc. down to the corresponding inserted row in the "Req1" column. I'm probably not explaining it very well.

I need the end result to look like:

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 am able to insert the correct number of rows but I'm stuck on looping through the columns and moving them down into the "Req1" column.

Any help is GREATLY appreciated!! Thanks in advance!

Answer 1

This macro will do what you want but instead of inserting rows it will put the data into a new sheet; You just need to add a sheet for output and change the name for input and output sheets in the code.

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

If you want to pursue the solution that you had by inserting the rows you need to add this loop after you inserted them. Also, you need to count number of rows while adding them. I do not have your code to see how it can be done but am sure it is easy to do so.

 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

you could work with arrays and slice them with 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