Adding empty rows, Help!

I am trying to use following macro to insert rows in a spreadsheet:

Sub Insert()
Dim j As Long, r As Range
j = InputBox("number of rows to be insered")
Set r = Range("A2")
Do
Range(r.Offset(1, 0), r.Offset(j, 0)).EntireRow.Insert
Set r = Cells(r.Row + j + 1, 1)
MsgBox r.Address
If r.Offset(1, 0) = "" Then Exit Do
Loop

End Sub

it does work, but add rows one by one at every entry
e.g.
when I run macro, it adds a row after A2, then a dialog box appears and I have to manually press Ok or close the box then it inserts another line after the next occupied row and so on.
Is there any way I can add empty rows at once or it automatically goes to next row without pressing anything manually?
i am very new to Excel, your help will be appreciated.
Thanks in advance

Moderators note: code tags added for you - this time