Add a new row every second and copy text.

[Marcus05]

I have a bunch of data in column A that I require copied to an inserted row above or below the existing data. For example the data would go from 1,2,3,4 to 1,1,2,2,3,3,4,4.
I would only like to do it on the cells/rows selected and not on the entire column.

 

[Joe4]

Welcome to the Board!

Try this code:

Sub MyInsertRows()

    Dim fr As Long, lr As Long
    Dim r As Long

    Application.ScreenUpdating = False

'   Find first and last rows of selected range
    With Selection
        fr = .Cells(1, 1).Row
        lr = .Rows(.Rows.Count).Row
    End With
    
'   Loop through all rows backwards
    For r = lr To fr Step -1
'       Insert blank row beneath
        Rows(r + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'       Copy value from current row to new row beneath
        Cells(r + 1, "A").Value = Cells(r, "A").Value
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[Marcus05]

Welcome to the Board!

Try this code:

Sub MyInsertRows()

    Dim fr As Long, lr As Long
    Dim r As Long

    Application.ScreenUpdating = False

'   Find first and last rows of selected range
    With Selection
        fr = .Cells(1, 1).Row
        lr = .Rows(.Rows.Count).Row
    End With
   
'   Loop through all rows backwards
    For r = lr To fr Step -1
'       Insert blank row beneath
        Rows(r + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'       Copy value from current row to new row beneath
        Cells(r + 1, "A").Value = Cells(r, "A").Value
    Next r
   
    Application.ScreenUpdating = True
   
End Sub

Thanks. This works when using MacOs and Microsoft 365. Would this code need to change if I was using Windows with 2019? I sometimes use both and the above doesn't seem to work. Just copies the cells 1,2,3,4 to 1,2,3,4,4,4,4.

 

[Joe4]

I use Office 365 for Windows and it works fine for me (I have never used Excel for Mac). I don't see anything in the code that should be problematic in 2019.
You can try changing this line:

Rows(r + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

to this:

Rows(r + 1).Insert Shift:=xlDown

to see if that makes any difference. That is the only possible command I could see that might not work exactly right in 2019?
Unfortunately I do not have 2019 myself to test it out.