Macro that inserts two blank rows after two rows of data

[Captain_Conman]

I could use help writing a macro that inserts two blank lines after two rows of data. For example...

My data looks like this...
Data 1
Data 1
Data 2
Data 2
Data 3
Data 3

and it should look like...
Data 1
Data 1
*Blank Row*
*Blank Row*
Data 2
Data 2
*Blank Row*
*Blank Row*
Data 3
Data 3

Also, my data has a header row if that makes a difference?

 

[Modesto73]

I guess there are a few ways to handle this, but this came to mind as the simplest:

Sub insert_rows()

Dim lr As Long
Dim ws As Worksheet


Set ws = Worksheets("Sheet1")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data based on column A
For i = 2 To lr * 2 Step 4 'assumes row 1 is headers and row 2 is where data starts
    ws.Rows(i + 2 & ":" & i + 3).Insert
Next i


End Sub

 

[Captain_Conman]

Thank you for your help!

Follow up:

What if I want to sum each couple of data? For example...
Data 1
Data 1
*Auto Sum Data 1*
*Blank Row*
Data 2
Data 2
*Auto Sum Data 2*
*Blank Row*
Data 3
Data 3
*Auto Sum Data 3*
*Blank Row*

 

[Modesto73]

Forgot to ask about odd rows... if after 2 data you get a sum and a blank, what happens if there is an odd number of data? This version will insert and sum every 2 rows, but will leave an odd item at the end alone:

Sub insert_rows()

Dim lr As Long
Dim ws As Worksheet


Set ws = Worksheets("Sheet1")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data based on column A
For i = 2 To (lr - 2) * 2 Step 4 'assumes row 1 is headers and row 2 is where data starts
    ws.Rows(i + 2 & ":" & i + 3).Insert
    ws.Range("A" & i + 2).Value = Application.Evaluate("=sum(A" & i & ":A" & i + 1 & ")")
Next i


End Sub

 

[Captain_Conman]

Forgot to ask about odd rows... if after 2 data you get a sum and a blank, what happens if there is an odd number of data? This version will insert and sum every 2 rows, but will leave an odd item at the end alone:

Sub insert_rows()

Dim lr As Long
Dim ws As Worksheet


Set ws = Worksheets("Sheet1")
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data based on column A
For i = 2 To (lr - 2) * 2 Step 4 'assumes row 1 is headers and row 2 is where data starts
    ws.Rows(i + 2 & ":" & i + 3).Insert
    ws.Range("A" & i + 2).Value = Application.Evaluate("=sum(A" & i & ":A" & i + 1 & ")")
Next i


End Sub

For the purpose of this workbook, there will never be an odd number of rows. There will only every be two rows for each.

 

[Modesto73]

In that case I hope this solved your issue

 

[Captain_Conman]

In that case I hope this solved your issue

Modesto! Thank you for your help. The VBA worked to insert the rows, however, the sum of every two rows is not working. Each cell has a zero where the total is, except for a few that have completely random totals. Not sure why this happend...

 

[jolivanes]

Try

Sub Insert_And_Sum()
Dim i As Long, Area As Range
i = 4
Application.ScreenUpdating = False
    Do
        Cells(i, 1).Resize(2).Insert Shift:=xlDown
        i = i + 4
    Loop While Len(Cells(i, 1)) > 0
    For Each Area In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
        Area.Cells(Area.Cells.Count).Offset(1).Formula = "=Sum(R[-2]C:R[-1]C)"
    Next Area
Application.ScreenUpdating = True
End Sub

Note: Please don't quote if not absolutely required. Refer to Post number instead if needed.

 

[Modesto73]

Odd that it is behaving that way... Worked well in my tests. But i wonder... Did you have headers? My code assumes you do and the data starts in row 2 and is all in column A.
Maybe jolivanes provided something more effective?