VBA to insert rows is not keeping cell contents or formula

[Stan101]

I have code to insert rows. A dialog pops up asking for the number of new rows required. Those rows are then inserted under. I am using "CopyOrigin" which by all accounts if to copy contents, formulas and formatting but it does not seem to be doing so.

Can anyone offer assistance? I would like to new inserted cells to have the same formatting and contents (and in future possibly formulas)

Also, how would you approach selectively copying contents from row above into these new cells.

EG: after adding 4 new rows after row 5, then copy the contents from B5, f5, and g5 to the new rows.

Sub InsertRows()


' Adds new blank lines based on the quantity added in the dialog box. It keeps formatting and forumlas.



Dim numRows As Integer

Dim counter As Integer


'Select the current row

   ActiveCell.EntireRow.Select

On Error GoTo Last

   numRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")


'Keep on inserting rows until we reach the desired number

For counter = 1 To numRows

   Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove

Next counter

  Last: Exit Sub

End Sub

 

[GWteB]

This might do what you're after

Sub InsertRows()

    ' Adds new blank lines based on the quantity added in the dialog box. It keeps formatting and forumlas.
    
    Dim numRows     As Long
    Dim raSource    As Range
    Dim bResult     As Boolean
    
    Set raSource = ActiveCell.EntireRow
    numRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")
    On Error Resume Next
    raSource.Offset(-1, 0).Copy
    bResult = Range(raSource, raSource.Offset(numRows - 1, 0)).EntireRow.Insert(Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove)
    Application.CutCopyMode = False
    If Not bResult Then
        MsgBox "Inserting rows failed!", vbExclamation
    End If
End Sub

 

[Stan101]

That works. I will play with it further to see what else I can achieve you you have taught me something new. Thanks.

 

[GWteB]

You are welcome and thanks for letting me know.