Inserting Rows and copying data.

[Yokiboha]

I have a sheet with unique rows into which I insert 2 blank rows after each filled row.

I need to copy into the two blank rows the data in the row immediately above them. Can anybody give me an easy way to do this?

 

[Mala]

The following code assumes data starts from A2:

Sub CopyInsertRows()
  LastRow = Cells(Rows.Count, 1).End(xlUp).Row
  Set DatRng = Range("A2", Cells(LastRow, 1))
  For i = LastRow To 2 Step -1
    Cells(i, 1).EntireRow.Copy
    Rows(i + 1).Resize(2, Columns.Count).Insert Shift:=xlDown
  Next i
  Application.CutCopyMode = False
End Sub

 

[Yokiboha]

Many thanks Mala, works perfectly.