InsertRowsAtValueChange.bas

Sub InsertRowsAtValueChange()
'Update 20140716
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Hoc Excel Online"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 2 Step -1
    If WorkRng.Cells(i, 1).Value <> WorkRng.Cells(i - 1, 1).Value Then
        WorkRng.Cells(i, 1).EntireRow.Insert
    End If
Next
Application.ScreenUpdating = True
End Sub