Copy Range until blank row N times VBA

[darthbane]

Hello all,
hoping to get your assistance with a VBA script.

I am looking to copy a range from one sheet and paste it to another sheet 4 times over.

for example:
range on sheet1:

Cell	value
A1	A
A2	B
A3	C
A4

<tbody>
</tbody>

the VBA would only copy the range A1:A3 (leaving the blank cell) and copy it onto another sheet 4 times over and paste a specific value in the adjacent cell
example:

cell	value	value2
a1	a	paste1
a2	a	paste2
a3	a	paste3
a4	a	paste4
a5	b	paste1
a6	b	paste2
a7	b	paste3
a8	b	paste4
a9	c	paste1
a10	c	paste2
a11	c	paste3

<tbody>
</tbody>

each time i run the script the initial range to be copied can change in size.

hope you can help!

 

[DanteAmor]

Try this

Sub test_Copy_Range()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, lr As Long
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    For Each c In sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp))
        lr = sh2.Range("A" & Rows.Count).End(xlUp).Row
        sh2.Range("A" & lr)(2).Resize(4).Value = c.Value
        sh2.Range("B" & lr)(2).Value = "paste1"
        sh2.Range("B" & lr)(2).AutoFill Destination:=Range("B" & lr + 1 & ":B" & lr + 4), Type:=xlFillDefault
    Next
End Sub

 

[darthbane]

Try this

Sub test_Copy_Range()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, lr As Long
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    For Each c In sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp))
        lr = sh2.Range("A" & Rows.Count).End(xlUp).Row
        sh2.Range("A" & lr)(2).Resize(4).Value = c.Value
        sh2.Range("B" & lr)(2).Value = "paste1"
        sh2.Range("B" & lr)(2).AutoFill Destination:=Range("B" & lr + 1 & ":B" & lr + 4), Type:=xlFillDefault
    Next
End Sub

it is giving me a subscript out of range error when i try to run it..

 

[DanteAmor]

it is giving me a subscript out of range error when i try to run it..

You have to put the names of your origin-destination leaves in this part:

    Set sh1 = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")   'Origin
    Set sh2 = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")   'Destination

 

[darthbane]

You have to put the names of your origin-destination leaves in this part:

    Set sh1 = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")   'Origin
    Set sh2 = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")   'Destination

oh wow, how did i not realize! thanks.

however i have one more ask - the values that get pasted into sheet two start in the 2nd row. i would actually like the paste to being in the 5th row. is there a way to do this with the script given?

 

[DanteAmor]

Try:

Sub test_Copy_Range()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, lr As Long
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    For Each c In sh1.Range("A1", sh1.Range("A" & Rows.Count).End(xlUp))
        lr = sh2.Range("A" & Rows.Count).End(xlUp).Row
        If lr < 5 then lr = 5
        sh2.Range("A" & lr)(2).Resize(4).Value = c.Value
        sh2.Range("B" & lr)(2).Value = "paste1"
        sh2.Range("B" & lr)(2).AutoFill Destination:=Range("B" & lr + 1 & ":B" & lr + 4), Type:=xlFillDefault
    Next
End Sub

 

[darthbane]

works perfectly when i try it! however when i try to use it to paste into my destination sheet that has a dynamic table, it will start pasting under the table. do you know if there is anyway to fix this or will i have to convert the table to a normal range?

 

[DanteAmor]

The macro always looks for the last row with data, but with a table, even if the cells are empty, the last row with data is the last row of the table.
You would help the macro a lot if you convert your table into normal range.