How to make insert rows faster above specific cell? [duplicate]

Question

I have made that simple subroutine to insert a number of rows above an active cell. It works well with a small volume of rows, but inserting 1000 rows, for example, takes ages.

Any ideas, please, for a faster approach?

Thank you

Option Explicit
Public Sub Insert_Rows()

  Dim i As Long
    Dim j As Variant
    j = InputBox("How many rows would you like to insert?", "Insert Rows")
    If j = "" Then
        j = 1
    End If
    For i = 1 To j
        ActiveCell.Rows.EntireRow.Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Next

End Sub

Answer 1

Insert Entire Rows Above the Active Cell

• Inserting many rows one at a time is very inefficient. Insert them at once instead.

A Quick Fix

• Replace the For...Next loop with the following line:

    ActiveCell.EntireRow.Resize(j) _
        .Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove

An Improvement

• The following code accounts for most of the many things that could go wrong with your simplified approach. The error-handling routine will account for any remaining 'surprises'.

Sub Insert_Rows()

    ' Define constants.
    Const PROC_TITLE As String = "Insert Rows"
    Const IB_PROMPT As String = _
        "How many rows would you like to insert?"
    Const INSERT_ONE_ROW_IF_NO_INPUT As Boolean = True
    Const SELECT_FORMERLY_ACTIVE_CELL As Boolean = False
    Const DISPLAY_SUCCESS_MESSAGE As Boolean = True
    
    ' Start an error-handling routine.
    On Error GoTo ClearError
    
    ' Check if no active cell.
    If ActiveCell Is Nothing Then ' no active cell (e.g. a chart is active)
        MsgBox "There is no active cell!", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Retrieve the user input.
    Dim InputString As String: InputString = InputBox(IB_PROMPT, PROC_TITLE)
    
    ' Optionally, assign "1" to the input string (to insert one row)
    ' when no input or input is cancelled.
    If INSERT_ONE_ROW_IF_NO_INPUT Then
        If Len(InputString) = 0 Then: InputString = "1"
    Else
        If Len(InputString) = 0 Then
            MsgBox "No input or cancelled!", vbExclamation, PROC_TITLE
            Exit Sub
        End If
    End If
    
    ' Check if the input string is not numeric.
    If Not IsNumeric(InputString) Then
        MsgBox """" & InputString & """ is not a number!", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Reference the objects.
    Dim cell As Range: Set cell = ActiveCell
    Dim ws As Worksheet: Set ws = cell.Worksheet
    Dim lcell As Range: Set lcell = _
        ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    
    ' Determine the maximum number of rows that can be inserted.
    Dim MaxRowsCount As Long:
    If lcell Is Nothing Then
        MaxRowsCount = ws.Rows.Count - cell.Row
    Else
        MaxRowsCount = ws.Rows.Count - Application.Max(cell.Row, lcell.Row)
    End If
    
    ' Convert the input to an integer (whole number).
    Dim RowsCount As Long:
    On Error Resume Next ' defer error handling ('ignore errors')
        RowsCount = CLng(InputString) ' integer if decimal, 0 if Overflow error
    On Error GoTo ClearError ' restart error-handling routine
    
    ' Check if the number of rows to insert is invalid (too small or too great).
    If RowsCount < 1 Or RowsCount > MaxRowsCount Then ' invalid number of rows
        MsgBox "Cannot insert " & InputString & " rows!", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Insert rows (without a loop).
    'Debug.Print cell.Address, ActiveCell.Address
    cell.Resize(RowsCount).EntireRow _
        .Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ' Note that at this point, the active cell remains the same,
    ' but 'cell' is a reference to the same cell that was formerly active
    ' but has shifted below the active cell.
    'Debug.Print cell.Address, ActiveCell.Address
     
    ' Optionally, select the formerly active cell.
    If SELECT_FORMERLY_ACTIVE_CELL Then Application.Goto cell
     
    ' Optionally, display a success message.
    If DISPLAY_SUCCESS_MESSAGE Then
        MsgBox "Inserted " & RowsCount & " rows above cell ""'" _
            & ws.Name & "'!" & cell.Address(0, 0) & """.", _
            vbInformation, PROC_TITLE
    End If
    
ProcExit:
    Exit Sub
ClearError:
    ' Continue error-handling routine.
    MsgBox "Run-time error [" & Err.Number & "]:" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub