VBA for inserting rows and copying the value above

[lintel]

Hi everyone.

I have a table with 2 columns A and B. Both columns contain a long list of numbers. I would like to run a makro that has two steps.

1) Insert a new row inbetween each row (my makro below does that already)
2) After inserting a new row it shall copy the value from the row above.

In other words. I have columns A and B and five rows as shown below.

A B
6 3
4 5
3 1
2 3

The makro shall then insert a new row between each line and copy the value from the cells above, so that the result will be:

A B
6 3
6 3
4 5
4 5
3 1
3 1
2 3
2 3

My makro is missing the 2nd step (copying the values from above). It currently looks like this:

Sub Insert_Blank_Rows()

'Select last row in worksheet.
Selection.End(xlDown).Select

Do Until ActiveCell.Row = 1
'Insert blank row.
ActiveCell.EntireRow.Insert shift:=xlDown
'Move up one row.
ActiveCell.Offset(-1, 0).Select

Loop

End Sub

Does anyone know how I include the 'copying from above' part?

Thank you so much,
Alex

 

[VoG]

Try

Sub Insert_Blank_Rows()
Dim LR As Long, i As Long
LR = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For i = LR To 1 Step -1
With Range("A" & i).EntireRow
    .Copy
    .Insert shift:=xlDown
    End With
Next i
End Sub

 

[Weaver]

try:

Sub insert()
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 2 Step -1
        With Rows(i)
            .Copy
            .Offset(1).insert xlDown
        End With
    Next
End Sub

 

[lintel]

You're a legend. Thanks, Peter.

 

[lintel]

Thank you Weaver, works perfectly.

 

[mark692]

good day sir how can i use this codeS?