VBA: Copy data range and paste every nth row and fill in the blanks

tommiexboi

New Member
Joined
Apr 24, 2017
Messages
24
Office Version
  1. 365
Platform
  1. Windows
Hello,

Need help! I tried searching google and the forums, but for the life of me I can't seem to find what I'm trying to look for.

I have a list of data in sheet1 and I'm trying to copy/paste each line into sheet2 on every 3rd row and then fill down the blanks. The list of data changes daily so I need it to loop until it reaches the end.
I created an example below.

I want to create a macro that can do this, your help will be greatly appreciated!!

Thanks,


EXAMPLE

Current (Sheet1)
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Customer[/TD]
[TD]Item[/TD]
[TD]Type[/TD]
[/TR]
[TR]
[TD]Pineapple[/TD]
[TD]Cup[/TD]
[TD]Beverage[/TD]
[/TR]
[TR]
[TD]Banana[/TD]
[TD]Bowl[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Strawberry[/TD]
[TD]Plate[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Mango[/TD]
[TD]Spoon[/TD]
[TD]Meal[/TD]
[/TR]
</tbody>[/TABLE]

Need (Sheet2)
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Customer[/TD]
[TD]Item[/TD]
[TD]Type[/TD]
[/TR]
[TR]
[TD]Pineapple[/TD]
[TD]Cup[/TD]
[TD]Beverage[/TD]
[/TR]
[TR]
[TD]Pineapple[/TD]
[TD]Cup[/TD]
[TD]Beverage[/TD]
[/TR]
[TR]
[TD]Pineapple[/TD]
[TD]Cup[/TD]
[TD]Beverage[/TD]
[/TR]
[TR]
[TD]Banana[/TD]
[TD]Bowl[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Banana[/TD]
[TD]Bowl[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Banana[/TD]
[TD]Bowl[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Strawberry[/TD]
[TD]Plate[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Strawberry[/TD]
[TD]Plate[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Strawberry[/TD]
[TD]Plate[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Mango[/TD]
[TD]Spoon[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Mango[/TD]
[TD]Spoon[/TD]
[TD]Meal[/TD]
[/TR]
[TR]
[TD]Mango[/TD]
[TD]Spoon[/TD]
[TD]Meal[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
This assumes your sheet tab names are Sheet1 and Sheet2 and that sheet2 already has the headers in place. Header "Customer" is assumed to be in cell A1 on both sheets.
Code:
Sub tommiexboy()
Dim R As Range, Rw As Range, lR As Long
Application.ScreenUpdating = False
Set R = Sheets("Sheet1").Range("A2:C" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
Sheets("Sheet2").Range("A2:C" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).ClearContents
For Each Rw In R.Rows
    Rw.Copy Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize(3, 3)
Next Rw
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Here is another macro (no loops) for you to consider...
Code:
[table="width: 500"]
[tr]
	[td]Sub tommiexboi()
  Dim Data As Variant
  Data = Split(Join(Application.Transpose(Evaluate(Replace("Sheet1!A2:A#&""|""&Sheet1!B2:B#&""|""&Sheet1!C2:C#", "#", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row))), "***"), "*")
  With Sheets("Sheet2")
    .Columns("A:C").Clear
    .Range("A1:C1").Value = Array("Customer", "Item", "Type")
    .Range("A2").Resize(UBound(Data) + 1) = Application.Transpose(Data)
    With .Range("A2:A" & UBound(Data) + 4)
      .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
      .Value = .Value
    End With
    .Columns("A").TextToColumns , xlDelimited, , , False, False, False, False, True, "|"
  End With
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Thank you JoeMo! This worked flawlessly! Had to tweak it just a little bit to suit my data, however; it worked completely fine!

Thank you Rick! This also worked well!

I owe you guys a beer! Cheers!
 
Upvote 0

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,633
Latest member
DougMo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top