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
Dim NC As Long
Dim cnt As Long
'***** EDIT the following lines ****
CC = 1 'Check this Column
FR = 2 'First Row with data: MINIMUM = 2
NR = 1 'Number of Rows to insert
'NC = 3 'Number of Columns to color
'***** END EDIT ****
Application.ScreenUpdating = False
LR = Cells(Rows.Count, CC).End(xlUp).Row
With Range(Cells(FR, CC), Cells(LR, CC))
Set rng = .Resize(.Rows.Count - 1)
End With
cnt = Evaluate("=SUMPRODUCT(--(" & rng.Address & "<>" & rng.Offset(1).Address & "))")
If LR + cnt > Rows.Count Then
MsgBox "Impossible to insert all rows!" & vbNewLine & vbNewLine & _
"Current last row:" & vbTab & LR & vbNewLine & _
"Rows to insert:" & vbTab & cnt & vbNewLine & _
"Available rows:" & vbTab & Rows.Count, vbCritical, "ERROR"
Exit Sub
End If
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
With .Resize(, NC + 1)
'.Interior.ColorIndex = 15
.Copy .Resize(NR * .Rows.Count, 1)
'.RowHeight = 5
End With
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
