Sub InsertBw()
     On Error GoTo errExit

     Dim sIn As String
     sIn = InputBox("Введите номер 1-й строки с данными, " & vbNewLine & _
                    "номер последней строки с данными" & vbNewLine & _
                    "через сколько строк нужно вставить по одной пустой строке, " & vbNewLine & _
                    "напр., так 1 5000 20", , "1 100 3")

     Dim av
     av = Split(sIn)
      
     Dim lFr As Long, lLr As Long, iSt As Integer
     lFr = av(0)
     lLr = av(1)
     iSt = av(2)
      
     Dim l As Long, sRngAddr As String
     For l = lFr + iSt To lLr Step iSt
         sRngAddr = sRngAddr & l & ":" & l & ","
     Next l
     sRngAddr = Left$(sRngAddr, Len(sRngAddr) - 1)
      
     Range(sRngAddr).Insert Shift:=xlDown

lblExit:
     Exit Sub
errExit:
     MsgBox "Произошла ошибка! ХЗ какая! Типа эта: " & Err.Description, vbCritical
     Resume lblExit
End Sub

Sub InsertRows()
Dim i As Long
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
            'For i = 2 To 200 Step 2
            '    Cells(i, 1).EntireRow.Insert
            'Next i
x = Cells(Rows.Count, 1).End(xlUp).Row
xx = 1
y = Cells(1, 5)
xxx = 0
up: If xx > x Then GoTo LastLine
xxx = xxx + 1
If xxx Mod y = 0 Then
xxx = 0
x = x + 1
Cells(xx + 1, 1).EntireRow.Insert
xx = xx + 1
End If
xx = xx + 1
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
GoTo up
LastLine:
End With
MsgBox "Ñòðîêè äîáàâëåíû!", vbInformation, "Âñòàâêà ñòðîê"
End Sub