• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Insert rows with formatting based on a cell value - automatically

Ellonash

New Member
Good Day,

I need to create a sheet, that when a cell is a completed with a specific number, that number of rows (specified in the cell) would automatically be inserted (without me having to run the macro. And when it inserts rows, the formatting of the line above should be duplicated / copied. Please see the macro below and advise if you can modify and assist me please?

The current macro is only inserting the rows, no formatting or automation in inserting the rows - Please see below - I've attached the Excel Workbook as well

Code:
Sub Insert()
'UpdatebyExtendoffice20170926
Dim xRg As Range
Dim xAddress As String
Dim I, xNum, xLastRow, xFstRow, xCol, xCount As Long
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Select a range to use(A1:H1):", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
xLastRow = xRg(1).End(xlDown).Row
xFstRow = xRg.Row
xCol = xRg.Column
xCount = xRg.Count
Set xRg = xRg(1)
For I = xLastRow To xFstRow Step -1
xNum = Cells(I, xCol)
If IsNumeric(xNum) And xNum > 0 Then
Rows(I + 1).Resize(xNum).Insert
xCount = xCount + xNum
End If
Next
xRg.Resize(xCount, 1).Select
Application.ScreenUpdating = True
End Sub

Your help would be much appreciated

Thank you
 

Attachments

  • VBA.xlsm
    15.3 KB · Views: 4
Last edited by a moderator:
Try this

Code:
Sub Insert()
  Dim xRg As Range
  Dim xAddress As String
   
  On Error GoTo Finito
  xAddress = ActiveWindow.RangeSelection.Address
  Set xRg = Application.InputBox("Select a range to use(A1:H1):", "Insert Formatted Rows", xAddress, , , , , 8)
  If xRg Is Nothing Then Exit Sub
   
  Application.ScreenUpdating = False
   
  Dim iRng As Range
  Set iRng = xRg.Offset(1, 0).Resize(xRg.Value, 5)
   
  'Insert Rows
  iRng.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   
  'Copy source row format
  Range(xRg, xRg.Offset(0, 4)).Copy
   
  'Paste format to new rows
  iRng.Offset(-xRg, 0).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=False
   
  'Cleanup
Finito:
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub
 
Back
Top