Improve Copy Paste Row performance in Macro

[Vivek D]

I have a spreadsheet where I need to provide an ability for users to add rows through a button click. The row that is added needs to have a lot of formulas in each of the columns which are already setup in the previous row.

I've therefore written a copy paste kind of code that ensures formulas are present in the newly added rows.

I didn't bother about performance as users were supposed to add a few rows at a time in most cases. However, users are now adding 100 rows pretty frequently and I want to therefore see how best the performance can be improved.

Note: In the code below "SectionName" basically tells in which horizontal section I want to add the rows as there are multiple horizontal sections in the spreadsheet. I have some unique text setup in the last row of each of the sections which helps in getting to the last row in section and then start the copy-paste process.

Here's the code that is present currently

Sub AddRow(SectionName As String)
       
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
       
    Dim RowsToAddInput As String
    Dim RowsToAdd As Integer
       
    ' Ask how many rows need to be added
    RowsToAddInput = InputBox(Prompt:="How many rows do you want to add (Max 100)?", Title:="Add Rows", Default:="1")
    On Error GoTo Err
   
    ' Check if an appropriate number has been entered
    If RowsToAddInput = "" Then 'Nothing has been entered or User pressed cancel button
        Exit Sub
    ElseIf Not IsNumeric(RowsToAddInput) Then 'User did not enter a number
        GoTo Err
    ElseIf RowsToAddInput < 1 Or RowsToAddInput > 100 Then 'User did not enter a value between 1 and 100
        GoTo Err
    Else
           
        RowsToAdd = CInt(RowsToAddInput)
       
        Application.StatusBar = "Rows are being added... Please be patient."
       
        Range("A1").Select
           
            Cells.Find(What:=SectionName, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False).Activate
           
        ' Start adding rows
        For i = 1 To RowsToAdd
           
            Rows(ActiveCell.Row - 1).Select 'Select the row to be copied
            Selection.Copy
            Rows(ActiveCell.Row).Select ' Select the row above. This is where the row will be pasted
            Selection.Insert Shift:=xlDown
            Application.CutCopyMode = False 'Copy Mode
                 
            Rows(ActiveCell.Row + 1).Select 'Select the newly added row
               
            On Error Resume Next 'to handle no constants in range
            Selection.SpecialCells(xlConstants).ClearContents 'Clear only constants and not the formulas
            Cells(ActiveCell.Row, 2).Select
       
        Next i
     End If
       
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
       
     Application.StatusBar = False
       
     Exit Sub
       
Err:
    MsgBox "Please enter a valid number between 1 and 100!"
    AddRow SectionName
   
End Sub

 

[Luke M]

Check out the speed on this baby.

Sub AddRow(SectionName As String)
   
Dim RowsToAddInput As String
Dim RowsToAdd As Integer, i As Integer
Dim myRow As Range

Application.ScreenUpdating = False
   
' Ask how many rows need to be added
RowsToAddInput = InputBox(Prompt:="How many rows do you want to add (Max 100)?", Title:="Add Rows", Default:="1")
On Error GoTo Err

' Check if an appropriate number has been entered
If RowsToAddInput = "" Then 'Nothing has been entered or User pressed cancel button
   Exit Sub
ElseIf Not IsNumeric(RowsToAddInput) Then 'User did not enter a number
   GoTo Err
ElseIf RowsToAddInput < 1 Or RowsToAddInput > 100 Then 'User did not enter a value between 1 and 100
   GoTo Err
End If
           
RowsToAdd = CInt(RowsToAddInput)

Application.StatusBar = "Rows are being added... Please be patient."

Set myRow = Cells.Find(What:=SectionName, After:=Range("A1"), LookIn:=xlFormulas, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Offset(-1, 0).EntireRow


' Start adding rows

myRow.Copy
'Use resize to insert all the rows at once
myRow.Resize(RowsToAdd).Insert shift:=xlDown
On Error Resume Next
myRow.Offset(-RowsToAdd, 0).Resize(RowsToAdd).SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo Err

Application.ScreenUpdating = True

Application.StatusBar = False

Exit Sub
       
Err:
    MsgBox "Please enter a valid number between 1 and 100!"
    AddRow SectionName
   
End Sub

 

[Vivek D]

Brilliant. It's lightning quick now! The Status bar message asking the user to be patient looks pretty silly now .

Just one small thing.. the final row remains selected, kind of how it is when one cuts a row. Pressing escape gets rid of it. How can I take that off prgramatically?

 

[Vivek D]

Just one small thing.. the final row remains selected, kind of how it is when one cuts a row. Pressing escape gets rid of it. How can I take that off prgramatically?

You can tell that I didn't write the earlier code all by myself.
The answer to my last question was in my code itself.

Application.CutCopyMode = False

 

[Luke M]

Oops, sorry about that. I should have caught that in the clean-up. Glad you found it, and like the results.

 

[toguko]

Nice code, thanks, saved for my use some day !!!