Copy/Paste any Selection N Times Vertically

[alexluchini]

Hello,

After a couple of hours of Googling and checking out these forums I decided to register and ask for help. I need a Macro that will Copy/Paste a selection of cells (that could change) "N" times vertically, without changing the order of the pasted selection.

I found a macro which ALMOST did what I wanted and I started hacking at it, this is close but still not correct, and it has errors:

Sub test()
Dim x As Integer
x = Application.InputBox("Number of Rows", "Number of Rows", Type:=1)
If x = False Then Exit Sub
Selection.Copy
Range(Selection.Offset(0), Selection.Offset(x)).EntireRow.Insert
Application.CutCopyMode = False
End Sub

Behavior:
I select a range, run the macro and an input box pops up asking how many times I'd like to paste the selected range. Perfect. The problem is, it doesn't offset and paste correctly.

Expected behavior:
When I enter the number of times I'd like to paste the range I'd like it to paste the range (without sorting, and keeping any formulas intact) vertically.

For example, if my Selected Range looked like this (keeping in mind my selected range could change):

[TABLE="width: 335"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]Col A[/TD]
[TD]Col B[/TD]
[TD]Col C[/TD]
[/TR]
[TR]
[TD]Text 1[/TD]
[TD]Text 1[/TD]
[TD]Text 1[/TD]
[/TR]
[TR]
[TD]Text 2[/TD]
[TD]Text 2[/TD]
[TD]Text 2[/TD]
[/TR]
[TR]
[TD]Text 3[/TD]
[TD]Text 3[/TD]
[TD]Text 3[/TD]
[/TR]
</tbody>[/TABLE]

I would want my pasted data to look like this:
[TABLE="width: 335"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]Col A[/TD]
[TD]Col B[/TD]
[TD]Col C[/TD]
[/TR]
[TR]
[TD]Text 1[/TD]
[TD]Other Text 1[/TD]
[TD]More Text 1[/TD]
[/TR]
[TR]
[TD]Text 2[/TD]
[TD]Other Text 2[/TD]
[TD]More Text 2[/TD]
[/TR]
[TR]
[TD]Text 3[/TD]
[TD]Other Text 3[/TD]
[TD]More Text 3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Text 1[/TD]
[TD]Other Text 1[/TD]
[TD]More Text 1[/TD]
[/TR]
[TR]
[TD]Text 2[/TD]
[TD]Other Text 2[/TD]
[TD]More Text 2[/TD]
[/TR]
[TR]
[TD]Text 3[/TD]
[TD]Other Text 3[/TD]
[TD]More Text 3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Text 1[/TD]
[TD]Other Text 1[/TD]
[TD]More Text 1[/TD]
[/TR]
[TR]
[TD]Text 2[/TD]
[TD]Other Text 2[/TD]
[TD]More Text 2[/TD]
[/TR]
[TR]
[TD]Text 3[/TD]
[TD]Other Text 3[/TD]
[TD]More Text 3[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Text 1[/TD]
[TD]Other Text 1[/TD]
[TD]More Text 1[/TD]
[/TR]
[TR]
[TD]Text 2[/TD]
[TD]Other Text 2[/TD]
[TD]More Text 2[/TD]
[/TR]
[TR]
[TD]Text 3[/TD]
[TD]Other Text 3[/TD]
[TD]More Text 3[/TD]
[/TR]
</tbody>[/TABLE]


Any help I can get would be much appreciated! Thank you.

 

[VBA Geek]

Sub pgojt()
Dim mR As Range
On Error Resume Next
Set mR = Application.InputBox("Select your Range", , , , , , , 8)
    If mR Is Nothing Then MsgBox "Nothing Selected!", vbExclamation: Exit Sub
On Error GoTo 0
Dim HowManyTimes As Integer: HowManyTimes = InputBox("How Many Times", , 1)
    If HowManyTimes < 1 Then MsgBox "Value Entered is not valid!", vbExclamation: Exit Sub
mR.Copy mR.Offset(mR.Rows.Count).Resize(mR.Rows.Count * HowManyTimes)
End Sub

 

[alexluchini]

It looks like this works PERFECTLY. Thank you so much!

 

[Reaganyee]

Sub pgojt()
Dim mR As Range
On Error Resume Next
Set mR = Application.InputBox("Select your Range", , , , , , , 8)
    If mR Is Nothing Then MsgBox "Nothing Selected!", vbExclamation: Exit Sub
On Error GoTo 0
Dim HowManyTimes As Integer: HowManyTimes = InputBox("How Many Times", , 1)
    If HowManyTimes < 1 Then MsgBox "Value Entered is not valid!", vbExclamation: Exit Sub
mR.Copy mR.Offset(mR.Rows.Count).Resize(mR.Rows.Count * HowManyTimes)
End Sub

Dear VBAGEEK,

This code worked perfectly for me as well. Would you mind briefly explaining how the code actually works?

Many thanks!

Reagan

 

[mmciz]

Sub pgojt()
Dim mR As Range
On Error Resume Next
Set mR = Application.InputBox("Select your Range", , , , , , , 8)
    If mR Is Nothing Then MsgBox "Nothing Selected!", vbExclamation: Exit Sub
On Error GoTo 0
Dim HowManyTimes As Integer: HowManyTimes = InputBox("How Many Times", , 1)
    If HowManyTimes < 1 Then MsgBox "Value Entered is not valid!", vbExclamation: Exit Sub
mR.Copy mR.Offset(mR.Rows.Count).Resize(mR.Rows.Count * HowManyTimes)
End Sub

May i know where i need to change if i want to use that macro as Horizontally .

 

[VBA Geek]

Off the top of my head, you would need to change the last line to:

mR.Copy mR.Offset(, mR.Columns.Count).Resize(, mR.Columns.Count * HowManyTimes)

 

[mmciz]

VBA Greek

Thank you so much for your reply .

Before i ask, i changed the last line to :

mR.Copy mR.Offset(mR.Columns.Count).Resize(mR.Columns.Count * HowManyTimes)

I didn't know that i need to add "," before mR.Columns.Count and mR.Columns.Count .

Now it works.

I DO thank you for your reply . And sorry for my bad english .

 

[jocker_boy]

Sub pgojt()
Dim mR As Range
On Error Resume Next
Set mR = Application.InputBox("Select your Range", , , , , , , 8)
    If mR Is Nothing Then MsgBox "Nothing Selected!", vbExclamation: Exit Sub
On Error GoTo 0
Dim HowManyTimes As Integer: HowManyTimes = InputBox("How Many Times", , 1)
    If HowManyTimes < 1 Then MsgBox "Value Entered is not valid!", vbExclamation: Exit Sub
mR.Copy mR.Offset(mR.Rows.Count).Resize(mR.Rows.Count * HowManyTimes)
End Sub

Hi,
Instead of copy paste, is it possible to copy and insert copied rows?

Thanks