Значение
пустая ячейка
значение
пустая ячейка

Sub InsertRows()
Dim a()
Dim rRng As Range
Dim lStart As Long, lRw As Long, lClmn As Long
Dim i As Long, n As Byte
    Set rRng = Application.InputBox("Выбрать диапазон", , Type:=8)
    lClmn = rRng.Column
    lStart = rRng.Row: lRw = rRng.Rows.Count + rRng.Row - 1

    a = Cells(1, lClmn).Resize(lRw + 2, 1).Value
    Application.ScreenUpdating = False

    For i = lRw To lStart Step -1
        If a(i, 1) <> Empty Then
            n = 0

            If a(i + 1, 1) <> Empty Then
                n = 2
            Else
                If a(i + 2, 1) <> Empty Then n = 1
            End If

            If n > 0 Then Cells(i + 1, lClmn).Resize(n, 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
    Next i

    Application.ScreenUpdating = True
    Set rRng = Nothing
End Sub