Sub InsetrRowAfterChangVar()
    Dim i As Integer, var As Variant, LastRow As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    var = Cells(LastRow, 1).Value
    For i = LastRow To 1 Step -1
        If var <> Cells(i, 1).Value Then
            var = Cells(i, 1).Value
            Cells(i + 1, 1).Insert Shift:=xlDown
        End If
    Next i
End Sub
' или
Sub InsetrRowAfterChangVar2()
    Dim i As Integer, var As Variant
    Application.ScreenUpdating = False
    var = Cells(1, 1).Value
    i = 1
    Do While var <> ""
        If var <> Cells(i, 1).Value Then
            var = Cells(i, 1).Value
            Cells(i, 1).Insert Shift:=xlDown
        End If
        i = i + 1
    Loop
End Sub