Auto-copy multiple formula when multiple rows are inserted

InsertName

New Member
Joined
Jan 26, 2018
Messages
2
I need some advice on vba for a worksheet I am using. The sheet is basically a template that will be populated by users, and as such I don't know the eventual size of the data set to be input. I want to include the option for users to insert rows anywhere in the table, but when I try this the columns which contain formulae are left blank and the users would have to fill them themselves.

What I'd like to happen is for the action of inserting new rows to automatically populate the new rows with the formula in the row above.

I've looked around online and found a few options for how to do it via a macro, but nothing seems to work exactly as desired. The closest I have managed to come to the working vba is below. This seems to worked but only for one row at a time - can anyone tell me how to amend this vba such that I can insert multiple rows at the same time, and the formula auto-populates for all of the new rows?

Thanks!



Option Explicit

Dim RowsCount As Long ' Variable to track number of rows used in sheet


Private Sub Worksheet_Activate()
RowsCount = Me.UsedRange.Rows.Count
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EH
' Detect whole row changed
If Target.Columns.Count = Me.Columns.Count Then
' Detect Extra Row
If RowsCount = Me.UsedRange.Rows.Count - 1 Then
' Copy Formulas and Format new row
Application.EnableEvents = False
If Target.Row > 1 Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, False, False
Target.PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
Application.CutCopyMode = False
End If
End If
RowsCount = Me.UsedRange.Rows.Count
End If

EH:
Application.EnableEvents = True
End Sub
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Hi & welcome to the board
How about this
Code:
Private Sub Worksheet_Change(ByVal Target As Range)

   Dim Rws As Long
   
   On Error GoTo EH
   ' Detect whole row changed
   If Target.Columns.Count = Me.Columns.Count Then
      ' Detect Extra Row
      Rws = Target.CountLarge / Me.Columns.Count
      If rowscount < Me.UsedRange.Rows.Count Then
         ' Copy Formulas and Format new row
         Application.EnableEvents = False
         If Target.Row > 1 Then
            Target.Offset(-1, 0).Resize(Rws + 1).FillDown
         End If
      End If
      rowscount = Me.UsedRange.Rows.Count
   End If
   
EH:
Application.EnableEvents = True
End Sub
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,212,938
Messages
6,110,771
Members
448,297
Latest member
cocolasticot50

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top