Adding lines and copying the content of each line based on a cell value

[scooper62]

Hi Forum,
This is my very first post in the forum and hope someone can help me.
I have no idea writing VBA but am sure there must be a VBA that can resolve my problem.

I have a large Excel file with hundreds of lines.
In column F I have a numerical value that based on this value I want additional lines added below this line.

I think the image that I have attached is self explanatory.
For example row 2 ( marked in yellow) has Qty 3 -- I need then 3 lines with all cells copied from row 2 - see below image.

Anyone here who can help build a VBA that I can simply copy and try it out?

Thanks
Steve

 

[mohadin]

Hi
And welcome
Try

Sub InsertRow()
    Dim x
    Dim lastrow, irow
    lastrow = Range("a2").End(xlDown).Row
    irow = lastrow
    Do Until irow = 1
        x = Cells(irow, 6).Value
        If x > 1 Then
            Rows(irow).EntireRow.Copy
            Rows(irow + 1).Resize(x - 1).Insert Shift:=xlDown
            Cells(irow, 6).Resize(x) = 1
        End If
        irow = irow - 1
    Loop
End Sub

 

[scooper62]

Sub InsertRow() Dim x Dim lastrow, irow lastrow = Range("a2").End(xlDown).Row irow = lastrow Do Until irow = 1 x = Cells(irow, 6).Value If x > 1 Then Rows(irow).EntireRow.Copy Rows(irow + 1).Resize(x - 1).Insert Shift:=xlDown Cells(irow, 6).Resize(x) = 1 End If irow = irow - 1 Loop End Sub

Works perfect
Thank you so much

 

[scooper62]

Hi
And welcome
Try

Sub InsertRow()
    Dim x
    Dim lastrow, irow
    lastrow = Range("a2").End(xlDown).Row
    irow = lastrow
    Do Until irow = 1
        x = Cells(irow, 6).Value
        If x > 1 Then
            Rows(irow).EntireRow.Copy
            Rows(irow + 1).Resize(x - 1).Insert Shift:=xlDown
            Cells(irow, 6).Resize(x) = 1
        End If
        irow = irow - 1
    Loop
End Sub

Hi Mohadin
You really helped me and I was wondering if the following can also be done in this VBA
To take total value in line, then divide by the QTY and then place the divided figure in each line.
I think what I attached explains much better.
This would be so amazing if possible.

Thank you

 

[mohadin]

Ok
Working on it
just give me some time Please
thanks

 

[scooper62]

Ok
Working on it
just give me some time Please
thanks

Thank you
Take as much time as you need - this is really helpful to me.

 

[mohadin]

Try

Sub InsertRow()
    Dim x
    Dim lastrow, irow
    lastrow = Range("a2").End(xlDown).Row
    irow = lastrow
    Do Until irow = 1
        x = Cells(irow, 6).Value
        If x > 1 Then
            Rows(irow).EntireRow.Copy
            Rows(irow + 1).Resize(x - 1).Insert Shift:=xlDown
            Cells(irow, 6).Resize(x) = 1
            Cells(irow, 7).Resize(x) = Cells(irow, 7) / x
        End If
        irow = irow - 1
    Loop
End Sub

 

[scooper62]

Sub InsertRow() Dim x Dim lastrow, irow lastrow = Range("a2").End(xlDown).Row irow = lastrow Do Until irow = 1 x = Cells(irow, 6).Value If x > 1 Then Rows(irow).EntireRow.Copy Rows(irow + 1).Resize(x - 1).Insert Shift:=xlDown Cells(irow, 6).Resize(x) = 1 Cells(irow, 7).Resize(x) = Cells(irow, 7) / x End If irow = irow - 1 Loop End Sub

You are a champion
Works perfect
Thank you so much

 

[mohadin]

You are very welcome
And thank you for the feedback
Be happy and safe
Allow me for final touch

Sub InsertRow()
    Dim x
    Dim lastrow, irow
    lastrow = Range("a2").End(xlDown).Row
    irow = lastrow
    Application.ScreenUpdating = False
    Do Until irow = 1
        x = Cells(irow, 6).Value
        If x > 1 Then
            Rows(irow).EntireRow.Copy
            Rows(irow + 1).Resize(x - 1).Insert Shift:=xlDown
            Cells(irow, 6).Resize(x) = 1
            Cells(irow, 7).Resize(x) = Cells(irow, 7) / x
        End If
        irow = irow - 1
    Loop
    Application.ScreenUpdating = True
End Sub