Macro to insert blank rows below data based on value of specific cell

[sneaky911]

First of all I'd like to apologize. I've seen a few threads addressing my issue but I'm unfamiliar with code and cannot figure out how to modify it to fit my specific data. I have 5 columns of data. (A-E) I'd like to look at the value in column D and insert 1 less number of rows directly below the data and then copy the data for the entire row down. Example: If value in column D=4, I'd like to insert 3 blank rows and then copy down. If value in column D=1, no additional rows needed. Any help would be greatly appreciated.

 

[synergy16]

can you show me a sample of the sheet.

 

[Joe4]

Someone may be able to come up with something a little more slick, but here is something quick I whipped up:

Sub MyCopy()

    Dim lastRow As Long
    Dim myRow As Long
    Dim myColD As Variant
    
    Application.ScreenUpdating = False
    
'   Find last row with data in column D
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    
'   Loop through rows backwards, up to row 2
    For myRow = lastRow To 2 Step -1
'       Check value in column D and if greater than 1, insert rows and copy
        myColD = Cells(myRow, "D")
        If myColD > 1 Then
            Rows(myRow + 1 & ":" & myRow + myColD - 1).Insert
            Rows(myRow).Copy
            Rows(myRow + 1 & ":" & myRow + myColD - 1).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End If
    Next myRow

    Application.ScreenUpdating = True
    
End Sub

 

[sneaky911]

This is exactly what I was looking for. Worked perfectly. Appreciate the help!

 

[Peter_SSs]

I'm not suggesting anything wrong with Joe's code, but there are two possible tweaks that you might want to consider.

1. The insertion of the new rows to accept the copied data can be done as part of the copy/paste process rather than a separate operation.

2. There is no need to turn off the CutCopymode each time through the loop, it can be done just once at the end.

So the last part of the code could become ..

'   Loop through rows backwards, up to row 2
    For myRow = lastRow To 2 Step -1
'       Check value in column D and if greater than 1, insert rows and copy
        myColD = Cells(myRow, "D")
        If myColD > 1 Then
            Rows(myRow).Copy
            Rows(myRow + 1).Resize(myColD - 1).Insert
        End If
    Next myRow
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

 

[sneaky911]

Sounds good. Thanks everyone for your help.