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

[tommiexboi]

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)

Customer	Item	Type
Pineapple	Cup	Beverage
Banana	Bowl	Meal
Strawberry	Plate	Meal
Mango	Spoon	Meal

<tbody>
</tbody>

Need (Sheet2)

Customer	Item	Type
Pineapple	Cup	Beverage
Pineapple	Cup	Beverage
Pineapple	Cup	Beverage
Banana	Bowl	Meal
Banana	Bowl	Meal
Banana	Bowl	Meal
Strawberry	Plate	Meal
Strawberry	Plate	Meal
Strawberry	Plate	Meal
Mango	Spoon	Meal
Mango	Spoon	Meal
Mango	Spoon	Meal

<tbody>
</tbody>

 

[JoeMo]

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.

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

 

[Rick Rothstein]

Here is another macro (no loops) for you to consider...

[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]

 

[tommiexboi]

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!