macro to add rows and copy row data

[anna1]

I need a macro that will add set number of rows between each existing row of data in my spreadsheet. Also the macro needs to allow the data row above the newly added blank rows to be copied into these blank rows. My spreadsheet has 28,000 rows of data that needs to be modified in this manner and I need a quick way to do this.

Any help will be greatly appreciated.

 

[TryingToLearn]

I believe this is what you asked for but I'm not sure it's what you meant.
It will find the last entry in column A, assume that is the last used row, add 2 blank lines after it, copy the last row to the line below and then work backwards though the entire file in the same matter.

End result, 2 lines of identical data followed by a blank.

Sub addNcopy()
    Dim r As Integer, Count As Integer
    Application.ScreenUpdating = False
    Count = Range("a65536").End(xlUp).Row
    For r = Count To 2 Step -1    ' work backwards to account for added lines
        If Cells(r, 1) <> vbNullString Then  ' skip blank lines
            ActiveSheet.Rows(r + 1).Insert
            ActiveSheet.Rows(r + 1).Insert
            ActiveSheet.Rows(r).Copy Destination:=ActiveSheet.Rows(r + 1)
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

 

[anna1]

Thanks for the help. It is close to what I need. Is there a way that each data row can be copied into all the blank rows. For ex. I have two data rows with "data a b c" and "data d e f". I want to add two blank rows between them and then copy the data row above into the two blank rows, etc. "Like this:

data a b c
data a b c
data a b c
data d e f
data d e f
data d e f

 

[TryingToLearn]

You mean:

Sub addNcopy() 
    Dim r As Integer, Count As Integer 
    Application.ScreenUpdating = False 
    Count = Range("a65536").End(xlUp).Row 
    For r = Count To 2 Step -1    ' work backwards to account for added lines 
        If Cells(r, 1) <> vbNullString Then  ' skip blank lines 
            ActiveSheet.Rows(r + 1).Insert 
            ActiveSheet.Rows(r + 1).Insert 
            ActiveSheet.Rows(r).Copy Destination:=ActiveSheet.Rows(r + 1) 
ActiveSheet.Rows(r).Copy Destination:=ActiveSheet.Rows(r + 2)
        End If 
    Next r 
    Application.ScreenUpdating = True 
End Sub

 

[anna1]

Thanks it works!

 

[moldfield]

Hi
Please could you tell me how to alter this for 49 additional rows?

Thanks