Sub InsertRows()
Dim i As Long, nRow As Long, k As Long
Dim x As Long
   With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      nRow = Cells(Rows.Count, 1).End(xlUp).Row

      k = InputBox("Введите количество строк для вставки между строками", , 1)

      For i = nRow To 2 Step -1
          If Cells(i, 6) = 2 Then
            Rows(i).Select
            Selection.Copy
              Selection.Insert Shift:=xlDown
          End If
         'Cells(i, 1).EntireRow.Insert

         If k > 1 Then
            For x = k To 2 Step -1
               Cells(i, 1).EntireRow.Insert
            Next x
         End If
      Next i

      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
   End With

   MsgBox "Строки добавлены!", vbInformation, "Вставка строк"
End Sub