Insert New Rows Between Rows

[Pendrant12]

Hey guys,
I found out that selecting multiple rows by hand and then inserting rows would result in inserting new rows between the selected rows.
The following macro shows this:

Sub Macro1() 
    Range("1:1,2:2,3:3").Select 
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
End Sub 

VBA tags courtesy of www.thecodenet.com

Now, what I need to do is this:

Sub test() 
     'Getting the last Row
    Cells(1, 1).Select 
    lastRow = Selection.End(xlDown).Row 
     'Building the Selection
    For i = 1 To lastRow 
        selectionString = selectionString & i & ":" & i & "," 
    Next i 
     'Removing the last ","
    selectionString = Mid(selectionString, 1, Len(selectionString) - 1) 
    Range(selectionString).Select 
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
End Sub 

VBA tags courtesy of www.thecodenet.com

This is trying to select each row individually to insert rows between the selected rows. As expected, I get the following error as it tries to select the rows:

Run-time error '1004':

Method 'Range' of object 'Global_' failed

I know there are plenty of ways to achieve the same result by creating a simple for-loop and inserting a new row after each row.
This is NOT what I want to do, since this seems to be a lot slower. (I am speaking about 200.000-300.000 rows)
Any ideas no how to get this working without a loop?

[dazwm]

See if this is any good for you. You highlight the rows you want to copy and insert then enter how many times.

Sub CopyAndInsertRow() 
    Dim NextRow As Long 
    Dim NrOfCopies As Long 
    Dim i As Long 
     
    Const NrOfCopiesDefault = 1 
    Const NrOfCopiesMaximum = 9 
     
    Do 
         
        On Error Resume Next 
        NrOfCopies = Application.InputBox(prompt:="How Many Copies Do You Want To Copy & Insert?", _ 
        Title:="# COPIES", Default:=NrOfCopiesDefault, Type:=1) 
        On Error Goto 0 
         
        If NrOfCopies = 0 Then 
            MsgBox "No copies made.", vbInformation, "CANCELLED" 
            Exit Sub 
        ElseIf NrOfCopies > NrOfCopiesMaximum Then MsgBox "Please Enter Number Of Copies Between 1 and " & NrOfCopiesMaximum, 48, "ERROR" 
        End If 
         
    Loop While NrOfCopies < 1 Or NrOfCopies > NrOfCopiesMaximum 
     
    With Selection 
        NextRow = .Row + .Rows.Count 
        Rows(NextRow & ":" & NextRow + .Rows.Count * (NrOfCopies) - 1).Insert Shift:=xlDown 
        .EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (NrOfCopies) - 1) 
        .Resize(.Rows.Count * (NrOfCopies + 1)).Sort Key1:=.Cells(1, 1) 
    End With 
     
End Sub 

VBA tags courtesy of www.thecodenet.com

[Pendrant12]

Pretty neat solution. I'll give it a try
Thanks