Option Explicit Sub InsertRowsAndFillFormulas_caller() '-- this macro shows on Tools, Macro..., Macros (Alt+F8) dialog Call InsertRowsAndFillFormulas End Sub Sub InsertRowsAndFillFormulas(Optional vRows As Long = 0) ' Documented: http://www.mvps.org/dmcritchie/excel/insrtrow.htm ' Re: Insert Rows -- 1997/09/24 Mark Hill ' row selection based on active cell -- rev. 2000-09-02 David McRitchie Dim x As Long ActiveCell.EntireRow.Select 'So you do not have to preselect entire row If vRows = 0 Then vRows = Application.InputBox(Prompt:= _ "How many rows do you want to add?", Title:="Add Rows", _ Default:=1, Type:=1) 'Default for 1 row, type 1 is number End If If vRows = False Then Exit Sub 'if you just want to add cells and not entire rows 'then delete ".EntireRow" in the following line 'rev. 20001-01-17 Gary L. Brown, programming, Grouped sheets Dim sht As Worksheet, shts() As String, i As Long ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _ Windows(1).SelectedSheets.Count) i = 0 For Each sht In _ Application.ActiveWorkbook.Windows(1).SelectedSheets Sheets(sht.Name).Select i = i + 1 shts(i) = sht.Name x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup Selection.Resize(rowsize:=2).Rows(2).EntireRow. _ Resize(rowsize:=vRows).Insert Shift:=xlDown Selection.AutoFill Selection.Resize( _ rowsize:=vRows + 1), xlFillDefault On Error Resume Next 'to handle no constants in range -- John McKee 2000/02/01 ' to remove the non-formulas -- 1998/03/11 Bill Manville Selection.Offset(1).Resize(vRows).EntireRow. _ SpecialCells(xlConstants).ClearContents Next sht Worksheets(shts).Select End Sub Sub InsertBlankRows() '-- Ken Wright, 2003-08-09 Application.ScreenUpdating = False Dim NumRows As Long Dim R As Long Dim Rng As Range Dim lastrw As Long NumRows = InputBox("How many Rows") lastrw = Cells(Rows.Count, "A").End(xlUp).Row Set Rng = Range(Cells(1, "A"), Cells(lastrw, "A")) For R = Rng.Rows.Count To 1 Step -1 Rng.Rows(R + 1).Resize(NumRows).EntireRow.Insert Next R Application.ScreenUpdating = True End Sub Sub InsertBlankRowBeforeLast() Cells(Rows.Count, "A").End(xlUp).EntireRow.Insert End Sub Sub Guarantee2RowsAfterA_values() Dim Rng As Range, i As Long Set Rng = Intersect(Columns("A:A"), ActiveSheet.UsedRange) For i = Rng.Cells.Count - 1 To 1 Step -1 If Trim(Rng(i).Value) <> "" Then If Trim(Rng(i + 1)) <> "" Then Rng.Item(i).Offset(1, 0).Resize(2).EntireRow.Insert ElseIf Trim(Rng(i + 2)) <> "" Then Rng.Item(i).Offset(1, 0).EntireRow.Insert End If End If Next i End Sub Sub Guarantee3RowsAfterA_values() Dim Rng As Range, i As Long Set Rng = Intersect(Columns("A:A"), ActiveSheet.UsedRange) For i = Rng.Cells.Count - 1 To 1 Step -1 If Trim(Rng(i).Value) <> "" Then If Trim(Rng(i + 1)) <> "" Then Rng.Item(i).Offset(1, 0).Resize(3).EntireRow.Insert ElseIf Trim(Rng(i + 2)) <> "" Then Rng.Item(i).Offset(1, 0).Resize(2).EntireRow.Insert ElseIf Trim(Rng(i + 3)) <> "" Then Rng.Item(i).Offset(1, 0).EntireRow.Insert End If End If Next i End Sub Public Sub Insert_Rows_betwn_existing() 'guarantee at least xx blank rows between rows in selection 'Sean Bartleet, excel.programming, 2005-10-20, mod. D.McR ' - http://google.com/groups?threadm=%23MKtkBY1FHA.2540%40TK2MSFTNGP09.phx.gbl Dim R As Long Dim n As Long Dim Rng As Range Dim myCell As Range Dim NumRows As Long, J As Long, inserts As Long If Selection.Rows.Count > 0 Then 'corrected since posting On Error Resume Next Set Rng = Intersect(Selection, ActiveSheet.UsedRange) If Rng.Rows.Count = 0 Then MsgBox "selection outside of used range" Exit Sub End If NumRows = Application.InputBox("Enter number of rows to insert " _ & "between each row in the selection", _ "Input number of guaranteed blank rows", 1, , , , , 1) If NumRows = 0 Then MsgBox "Cancelled by your command" Exit Sub End If On Error GoTo EndMacro Application.ScreenUpdating = False Application.Calculation = xlCalculationManual n = 0 For R = Rng.Rows.Count To 1 Step -1 If Rng.Cells(R, 1) <> "" Then For J = 1 To NumRows If Rng.Cells(R + J, 1) <> "" Then Rng.Rows(R + 1).Resize(NumRows + 1 - J).EntireRow.Insert n = n + 1 inserts = inserts + NumRows + 1 - J End If Next J End If Next R MsgBox (n & " insertion points for" & NumRows & _ " blank rows required between populate rows, " _ & inserts & " blank rows actually inserted" _ & "within preselected range") Rng.Select '-- show scope based on original range Else MsgBox ("Must select one or more rows for range " _ & "before executing command") End If '-- the following sometimes works but apparently not here J = ActiveSheet.UsedRange.Rows.Count 'see J-Walkenbach tip 73 EndMacro: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub InsertRow_A_Chg() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim irow As Long, vcurrent As String, i As Long '// find last used cell in Column A irow = Cells(Rows.Count, "A").End(xlUp).Row '// get value of that cell in Column A (column 1) vcurrent = Cells(irow, 1).Text '// rows are inserted by looping from bottom For i = irow To 2 Step -1 If Cells(i, 1).Text = "" Then vcurrent = Cells(i - 1, 1) ElseIf Cells(i, 1).Text <> vcurrent Then vcurrent = Cells(i, 1).Text Rows(i + 1).Insert End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub