HELP auto insert 2 rows in a spreadsheet

Option Explicit

Sub insert_rows_on_each_change()
'Erik Van Geit
'080628

'EXAMPLE
'CC = 3, FR = 2, NR = 2
'START WITH
'a1  b1  header  d1
'a2  b2  A   d2
'a3  b3  A   d3
'a4  b4  B   d4
'a5  b5  C   d5
'a6  b6  C   d6
'RESULT
'a1  b1  header  d1
'a2  b2  A   d2
'a3  b3  A   d3
'
'
'a4  b4  B   d4
'
'
'a5  b5  C   d5
'a6  b6  C   d6

Dim rng As Range
Dim LR As Long              'Last Row
Dim CC As Long
Dim FR As Long
Dim NR As Long

'***** EDIT the following lines ****
CC = 1        'Check this Column
FR = 1        'First Row with data: MINIMUM = 2
NR = 2        'Number of Rows to insert
'***** END EDIT ****

Application.ScreenUpdating = False

LR = Cells(Rows.Count, CC).End(xlUp).Row
Columns(CC).EntireColumn.Insert

Set rng = Range(Cells(FR + 1, CC), Cells(LR, CC))

Cells(FR, CC) = 1

    With rng
    .FormulaR1C1 = "=IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1)"
    .Value = .Value
        With .Offset(.Rows.Count, 0)
        .Cells(1, 1).Value = 1
            With .Resize(.Cells(1, 1).Offset(-1, 0) - 1, 1)
            .DataSeries Rowcol:=xlColumns, Type:=xlLinear, step:=1
            .Copy .Resize(NR * .Rows.Count, 1)
            End With
        End With
    LR = Cells(Rows.Count, CC).End(xlUp).Row
    Range(Cells(FR, CC), Cells(LR, CC)).EntireRow.Sort Key1:=.Cells(1, 1)
    End With

Columns(CC).EntireColumn.Delete

Application.ScreenUpdating = True

End Sub

RANGE   FORMULA (1st cell)
F6      =SUBTOTAL(9,F2:F5)
F10     =SUBTOTAL(9,F7:F9)
F13     =SUBTOTAL(9,F11:F12)
F14     =SUBTOTAL(9,F2:F12)

[Table-It] version 05 by Erik Van Geit