Insert rows based on the current cell value and, then, copy some cells into the new rows

Hello All,

I am a fairly experienced Excel user, but new to VBA and macros. I have recorded some macros and done a bit of editing of the VBA code.

I am trying to create a macro that will, based on the value of the current cell, insert X minus 1 new rows below the current row, where X is the value of the current cell and, then, copy some cells from the current row straight down into the new blank rows.

For example, if the data is located in the range J10:O13 as follows and J10 is the starting cell:

___J__K__L__M__N__O

10__3__X__X__X__X__X
11__2__X__X__X__X__X
12__3__X__X__X__X__X
13__1__X__X__X__X__X


The macro would change the data to:

___J__K__L__M__N__O

10__3__X__X__X__X__X
11_____X__X__X__X__X
12_____X__X__X__X__X
13__2__X__X__X__X__X
14_____X__X__X__X__X
15__3__X__X__X__X__X
16_____X__X__X__X__X
17_____X__X__X__X__X
18__1__X__X__X__X__X


Note: I had to include the underscores above just to get the columns to line up. Only the cells in columns K thru O are copied down into the new rows, not the cells in column J.


I did find the following macro which works perfectly to insert the new rows, but I cannot seem to add the proper code to get the specified cells from the current row to copy down into the new cells:

Sub Insert_Rows()
'
' Insert_Rows Macro
'
' Keyboard Shortcut: Ctrl+i
'
Dim i As Integer, n As Integer, m As Long, currentCell As Range
    Set currentCell = ActiveCell
    Do While Not IsEmpty(currentCell)
        n = currentCell.Value - 1
        m = currentCell.Row
        If n > 0 Then
            Rows(m + 1 & ":" & m + n).Insert
            Set currentCell = currentCell.Offset(n + 1, 0)
        Else
            Set currentCell = currentCell.Offset(1, 0)
        End If
    Loop

End Sub

I have read that it is better to start at the bottom of the data and move up when inserting rows and I do wonder if that may be related to my problem of not getting the copy/paste to work properly.

Here is the code that I tried to add for copying and pasting:

ActiveCell.Offset(0, 1).Range("A1:K1").Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Range("A1:K3").Select
            ActiveSheet.Paste

It does copy and paste, but the pasted data keeps shifting one column to the right each time the macro loops.

Thanks for any help anyone can provide!

RZ