Hi again,
Thanks for noting The Dogs Trust
As you want to use different approaches for specifying the parameters in the Add Rows and Delete Rows operations, we can't use as much "common code" as before.
The following code allows you to specify non-touching rows for deletion, and displays a message asking you to confirm the delete operation:
Option Explicit
'==========================================================================================
'==========================================================================================
Const miMINIMUM_START_ROW_NO As Integer = 6
Const miMAX_NO_OF_ROWS As Integer = 9
Const msPASSWORD As String = "password"
'==========================================================================================
'==========================================================================================
Sub AddRows()
Const iHIDDEN_ROW_NO As Integer = 1
Dim iNoOfRowsToAdd As Integer
Dim vaWorksheets As Variant
Dim iStartRowNo As Integer
Dim vWorksheet As Variant
iNoOfRowsToAdd = miNoOfRowsToAdd()
If iNoOfRowsToAdd > 0 Then
iStartRowNo = miStartRowNo()
If iStartRowNo > 0 Then
vaWorksheets = mvaWorksheets()
For Each vWorksheet In vaWorksheets
With vWorksheet
.Unprotect Password:=msPASSWORD
With .Rows(iStartRowNo).Resize(RowSize:=iNoOfRowsToAdd)
.Insert
.Offset(-iNoOfRowsToAdd, 0).Formula = vWorksheet.Rows(iHIDDEN_ROW_NO).Formula
End With
.Protect Password:=msPASSWORD
End With
Next vWorksheet
End If
End If
End Sub
'==========================================================================================
'==========================================================================================
Sub DeleteRows()
Dim sRowsToDelete As String
Dim vaWorksheets As Variant
Dim vWorksheet As Variant
sRowsToDelete = msRowsToDelete()
If sRowsToDelete <> vbNullString Then
vaWorksheets = mvaWorksheets()
For Each vWorksheet In vaWorksheets
With vWorksheet
.Unprotect Password:=msPASSWORD
vWorksheet.Range(sRowsToDelete).Delete
.Protect Password:=msPASSWORD
End With
Next vWorksheet
End If
End Sub
'==========================================================================================
'==========================================================================================
Private Function mvaWorksheets() As Variant
Const sSHEET_NAME_1 As String = "Worksheet A"
Const sSHEET_NAME_2 As String = "Worksheet B"
Const sSHEET_NAME_3 As String = "Worksheet C"
With ThisWorkbook
mvaWorksheets = Array(.Worksheets(sSHEET_NAME_1), .Worksheets(sSHEET_NAME_2), _
.Worksheets(sSHEET_NAME_3))
End With
End Function
'==========================================================================================
'==========================================================================================
Private Function miNoOfRowsToAdd() As Integer
Const iINPUT_TYPE_NO As Integer = 1
Dim iNoOfRowsToAdd As Integer
iNoOfRowsToAdd = 0
iNoOfRowsToAdd = Application.InputBox(Prompt:="How many rows should be added?", _
Title:="Add Rows", _
Type:=iINPUT_TYPE_NO)
If iNoOfRowsToAdd > 0 Then
If iNoOfRowsToAdd <= miMAX_NO_OF_ROWS Then
miNoOfRowsToAdd = iNoOfRowsToAdd
Else: MsgBox "A maximum of " & miMAX_NO_OF_ROWS & " new rows may be added", _
vbExclamation
miNoOfRowsToAdd = 0
End If
End If
End Function
'==========================================================================================
'==========================================================================================
Private Function miStartRowNo() As Integer
Const iINPUT_TYPE_RANGE As Integer = 8
Dim rStartRowCell As Range
Dim iStartRowNo As Integer
Dim sPrompt As String
iStartRowNo = 0
sPrompt = "Select the cell at which the Add Rows operation should start"
On Error Resume Next
Set rStartRowCell = Nothing
Set rStartRowCell = Application.InputBox(Prompt:=sPrompt, Title:="Add Rows", _
Type:=iINPUT_TYPE_RANGE)
On Error GoTo 0
If Not rStartRowCell Is Nothing Then
If rStartRowCell.Cells.Count = 1 Then
If rStartRowCell.Row >= miMINIMUM_START_ROW_NO Then
miStartRowNo = rStartRowCell.Row
Else: MsgBox "The start row may not be above Row " & miMINIMUM_START_ROW_NO, _
vbExclamation
End If
Else: MsgBox "Only a single cell may be selected", vbExclamation
End If
End If
End Function
'==========================================================================================
'==========================================================================================
Private Function msRowsToDelete() As String
Dim iNoOfRowsToDelete As Integer
Dim rRowsToDelete As Range
Dim sMessage As String
Dim iYesNo As Integer
Dim rRow As Range
Set rRowsToDelete = Selection
iNoOfRowsToDelete = 0
On Error Resume Next
iNoOfRowsToDelete = rRowsToDelete.Rows.Count
On Error GoTo 0
If iNoOfRowsToDelete > 0 Then
If iNoOfRowsToDelete <= miMAX_NO_OF_ROWS Then
For Each rRow In rRowsToDelete.Rows
If rRow.Row >= miMINIMUM_START_ROW_NO Then
sMessage = sMessage & vbLf & vbTab & rRow.Row
Else: MsgBox "Rows above Row " & miMINIMUM_START_ROW_NO & _
" may not be selected for deletion", vbExclamation
Set rRowsToDelete = Nothing
Exit For
End If
Next rRow
Else: MsgBox "A maximum of " & miMAX_NO_OF_ROWS & " rows may be deleted", _
vbExclamation
Set rRowsToDelete = Nothing
End If
If Not rRowsToDelete Is Nothing Then
sMessage = "The following rows will be permanently deleted:" & _
vbLf & sMessage & vbLf & vbLf & _
"Do you wish to continue?"
iYesNo = MsgBox(sMessage, vbYesNo + vbDefaultButton2)
If iYesNo = vbYes Then
msRowsToDelete = rRowsToDelete.EntireRow.Address
Else: msRowsToDelete = vbNullString
End If
End If
End If
End Function
Hope this helps - as always, please keep me posted!
Regards,
Greg M
Bookmarks