Force a user to select the entire row from row number

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
467
Office Version
  1. 365
Platform
  1. Windows
Can somebody help a bit please, I have cobbled together the below code to allow the user to insert extra rows. But I have a couple of problems.

1. I need be able to force the user to select the entire row, because at the moment if they select a cell not the row, the code just inserts a copy the active cell. I did try “ActiveCell.EntireRow.Copy” but this errored out on the next line “Selection.Insert Shift:=xlDown”.

2. The other part I would like to achieve is I would like to put something in column O like (do not insert rows here) so the code would check for this value and prevent any rows being entered, with a msgbox stating that you cannot insert rows here. This will enable me to protect parts of the sheet from the user inserting rows.

Any help is much appreciated

Code:
Sub AddRows()

    Dim n As Integer
    Dim Ans As Variant
'    On Error Resume Next

ActiveSheet.Unprotect
 Ans = MsgBox("Have you selected the entire row where you want to add the extra rows", vbYesNo)
 If Ans = vbYes Then

    n = InputBox("How many rows do you require?")
        If n >= 1 Then
            For numtimes = 1 To n
              Selection.Copy
    Selection.Insert Shift:=xlDown

Next
End If
ActiveSheet.Protect

Else
ActiveSheet.Protect
   Exit Sub
   End If
End Sub
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Re point 1, try replacing this :
Code:
n = InputBox("How many rows do you require?")
If n >= 1 Then
    For numtimes = 1 To n
        Selection.Copy
        Selection.Insert Shift:=xlDown
    Next
End If

With this :
Code:
n = InputBox("How many rows do you require?")
Selection.Resize(n).EntireRow.Copy
Selection.EntireRow.Insert

And this can be removed :
Code:
Ans = MsgBox("Have you selected the entire row where you want to add the extra rows", vbYesNo)
If Ans = vbYes Then
 
Last edited:
Upvote 0
Here's the whole revised macro :
Code:
Sub AddRows()
Dim n As Integer
ActiveSheet.Unprotect
n = InputBox("How many rows do you require?")
Selection.Resize(n).EntireRow.Copy
Selection.EntireRow.Insert
ActiveSheet.Protect
End Sub

You might want to add some error handling for the input box.
 
Last edited:
Upvote 0
OK not as tidy as footoo's but done it now

Code:
Sub AddRows()


    Dim n As Integer
    
    If Cells(ActiveCell.Row, "O") <> "Do Not Insert" Then
        ActiveSheet.Unprotect
        n = InputBox("How many rows do you require?")
        
        If n >= 1 Then
            ActiveCell.EntireRow.Copy
            Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(n, 0)).EntireRow.Insert Shift:=xlDown
            Application.CutCopyMode = False
        End If
        ActiveSheet.Protect
    Else
        MsgBox "Insertion not allowed", vbCritical, "Error"
    End If
End Sub
 
Upvote 0
With some error handling added for the selection and the input box (but without the column O bit) :
Code:
Sub AddRows()
Dim n As Variant


If TypeName(Selection) <> "Range" Then
    MsgBox "Select a worksheet cell."
    Exit Sub
ElseIf Selection.Rows.Count > 1 Then
    MsgBox "Select in one row only."
    Exit Sub
ElseIf Selection.Row < 2 Then 'Assuming row 1 is a header row
    MsgBox "The selection must not be in the header row(s)"
End If


Application.DisplayAlerts = False
n = Application.InputBox(Prompt:="How many rows do you require?", Type:=1)
Application.DisplayAlerts = True
If TypeName(n) = "Boolean" Or n = 0 Then Exit Sub
n = Val(n)


ActiveSheet.Unprotect
Selection.Resize(n).EntireRow.Copy
Selection.EntireRow.Insert
ActiveSheet.Protect
End Sub
 
Last edited:
Upvote 0
You might also want to restrict the number of rows to add :
Code:
Sub AddRows()
Dim n As Variant


If TypeName(Selection) <> "Range" Then
    MsgBox "Select a worksheet cell."
    Exit Sub
ElseIf Selection.Rows.Count > 1 Then
    MsgBox "Select in one row only."
    Exit Sub
ElseIf Selection.Row < 2 Then 'Assuming row 1 is a header row
    MsgBox "The selection must not be in the header row(s)"
End If


Application.DisplayAlerts = False
n = Application.InputBox(Prompt:="How many rows do you require?", Type:=1)
Application.DisplayAlerts = True
If TypeName(n) = "Boolean" Or n = 0 Then Exit Sub
n = Val(n)
[COLOR=#ff0000]If n > 99 Then 'To restrict the maximum number of rows to add[/COLOR]
[COLOR=#ff0000]    MsgBox "Enter a number less than 100"[/COLOR]
[COLOR=#ff0000]    Exit Sub[/COLOR]
[COLOR=#ff0000]End If[/COLOR]


ActiveSheet.Unprotect
Selection.Resize(n).EntireRow.Copy
Selection.EntireRow.Insert
ActiveSheet.Protect
End Sub
 
Last edited:
Upvote 0
Thanks for all your assistance
All working OK apart from I am not getting the msgbox "Insertion not allowed" up when I try to enter rows where I have Do not insert Rows in column O, although it is preventing me from inserting any rows, it just exits the sub.

It does however pop up if I select vbno from the Ans = MsgBox("Have you selected the entire row where you want to add the extra rows", vbYesNo)

Code below


Code:
Sub AddRows()

    Dim n As Integer
    Dim Ans As Variant
'    On Error Resume Next

If Cells(ActiveCell.Row, "O") <> "Do not insert Rows" Then
        Ans = MsgBox("Have you selected the row where you want to add the extra rows", vbYesNo)
            If Ans = vbYes Then
             ActiveSheet.Unprotect
             n = InputBox("How many rows do you require?")
        If n >= 1 Then
            For numtimes = 1 To n
        Selection.Resize(n).EntireRow.Copy
    Selection.EntireRow.Insert
Next
   Application.CutCopyMode = False
End If
ActiveSheet.Protect
Else
    MsgBox "Insertion not allowed", vbCritical, "Error"
   End If
   End If
End Sub
 
Upvote 0
The code in post # 8 is not the same as has been suggested.
For example, the changes you have made means that if the input box contains 5 (say), 25 rows (i.e. 5 times 5) get inserted.
 
Upvote 0
Apologies Footoo
Got it now
Thanks for everything
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,192
Members
448,554
Latest member
Gleisner2

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