A
Art
I have a protected sheet in Excel 2007, and I would like to write a macro
that allows a user to insert a new row(s) that also copies the formulas (but
not the text/data) from the previous row.
When I searched for a possible solution, I found the following macro #2,
which works perfectly, if the sheet is unprotected. I use the following code
(macro #1) in another macro to unprotect a sheet temporarily to run a macro,
then re-protect it.
I select a row on the spreadsheet and run the macro
InsertRowsAndFillFormulas_caller(). I get a "Compile Error: Invalid or
Unqualified reference".
Any thoughts how to use Macro #2 and embedding Macro #1 so the sheet is
temporarily unprotected, code to insert row/copy formulas is completed, then
sheet is protected again?
-----------------------------------------------------------
MACRO #1---Unprotect Sheet/Re-protect Sheet
-----------------------------------------------------------
Dim strSheetName As String
strSheetName = ActiveSheet.Name
Const MyPassword As String = "kendallpassword"
Dim ChangeProtection As Boolean
With Sheets(strSheetName)
If .ProtectContents = True Then
.Unprotect (MyPassword)
ChangeProtection = True
End If
If ChangeProtection = True Then .Protect (MyPassword)
-----------------------------------------------------------
MACRO #2---INSERT ROW/COPY FORMULA
-----------------------------------------------------------
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 <[email protected]>
' row selection based on active cell -- rev. 2000-09-02 David McRitchie
Const MyPassword As String = "kendall415"
Dim ChangeProtection As Boolean
If .ProtectContents = True Then
.Unprotect (MyPassword)
ChangeProtection = True
End If
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 '<a
href="lastcell.htm#resetall">lastcell fixup</a>
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, <a
href="http://google.com/groups?threadm=#[email protected]">2003-08-09</a>
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
If ChangeProtection = True Then .Protect (MyPassword)
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=#[email protected]
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
that allows a user to insert a new row(s) that also copies the formulas (but
not the text/data) from the previous row.
When I searched for a possible solution, I found the following macro #2,
which works perfectly, if the sheet is unprotected. I use the following code
(macro #1) in another macro to unprotect a sheet temporarily to run a macro,
then re-protect it.
I select a row on the spreadsheet and run the macro
InsertRowsAndFillFormulas_caller(). I get a "Compile Error: Invalid or
Unqualified reference".
Any thoughts how to use Macro #2 and embedding Macro #1 so the sheet is
temporarily unprotected, code to insert row/copy formulas is completed, then
sheet is protected again?
-----------------------------------------------------------
MACRO #1---Unprotect Sheet/Re-protect Sheet
-----------------------------------------------------------
Dim strSheetName As String
strSheetName = ActiveSheet.Name
Const MyPassword As String = "kendallpassword"
Dim ChangeProtection As Boolean
With Sheets(strSheetName)
If .ProtectContents = True Then
.Unprotect (MyPassword)
ChangeProtection = True
End If
If ChangeProtection = True Then .Protect (MyPassword)
-----------------------------------------------------------
MACRO #2---INSERT ROW/COPY FORMULA
-----------------------------------------------------------
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 <[email protected]>
' row selection based on active cell -- rev. 2000-09-02 David McRitchie
Const MyPassword As String = "kendall415"
Dim ChangeProtection As Boolean
If .ProtectContents = True Then
.Unprotect (MyPassword)
ChangeProtection = True
End If
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 '<a
href="lastcell.htm#resetall">lastcell fixup</a>
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, <a
href="http://google.com/groups?threadm=#[email protected]">2003-08-09</a>
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
If ChangeProtection = True Then .Protect (MyPassword)
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=#[email protected]
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