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

Sub InsertRows()
Dim rRng As Range
Dim lStart As Long, lRw As Long, lClmn As Long
Dim i As Long
    Set rRng = Selection: lClmn = rRng.Column
    lStart = rRng.Row + 1: lRw = rRng.Rows.Count + rRng.Row
    Application.ScreenUpdating = False

    For i = lRw To lStart Step -1
        If rRng(i, 1).Value <> "" Then
'            Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(i, lClmn).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
    Next i

    Application.ScreenUpdating = True
    Set rRng = Nothing
End Sub