Adding Rows to a worksheet

Hi,

I have the following piece of code which adds a user entered number of rows to a worksheet. However, as I already have one row in existance (which it copies x times) I'd like it to take one off the total entered by the user as it means I end up with one row more than is required.

Im sure it's simple enough and i've tried my best to work it out on my own,but just end up with some runtime errors....(I set i to -1 but im guessing that's a schoolboy error!)

Private Sub CommandButton1_Click()

'adds desired # of lines below the current line and
' copies the formulas to that/those lines
'added selection of more than one worksheet

Dim vRows As Long
Dim sht As Worksheet, shts() As String, i As Long

' row selection based on active cell --

ActiveCell.EntireRow.Select
vRows = _
Application.InputBox(prompt:= _
"How many students are taking this (shared) module?", Title:="Add Rows", _
Default:=0, Type:=1) 'type 1 is number

If vRows = False Then Exit Sub
'if you just want to add cells and not entire rows
' then delete ".EntireRow" in the following line

ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0

'insert rows on grouped worksheets

For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name

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 remove the non-formulas
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents
Next sht

'reselect original group
Worksheets(shts).Select


End Sub