VBA copy cell ranges and paste each cell n times into a different sheet

[Multim]

Hello
I'm a VBA novice and normally can cobble something together but am stuck with this one.

I have a sheet called "Inventory Details" and a list of part numbers in cell A2 down, this will be a variable number of part numbers, I need each cell copied then pasted 6 times into a Sheet called " Routing Info" starting in A2 and the the next cell pasted 6 times below and so on.

Any assistance would be greatly appreciated.

"Inventory Details" Cells

" Routing Info" sheet final requirement

Thank you

 

[Joe4]

Try this:

Sub MyCopyData()

    Dim wsInv As Worksheet
    Dim wsRtg As Worksheet
    Dim lr As Long
    Dim r As Long
    
    Application.ScreenUpdating = False
    
'   Set worksheet objects
    Set wsInv = Worksheets("Inventory Details")
    Set wsRtg = Worksheets("Routing Info")
    
'   Find last row in column A with data on Inventory Detils sheet
    lr = wsInv.Cells(wsInv.Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows starting on row 2
    For r = 2 To lr
'       Populate next 6 rows on Routing Info sheet
        wsRtg.Range(wsRtg.Cells(((r - 2) * 6) + 2, "A"), wsRtg.Cells(((r - 2) * 6) + 7, "A")).Value = wsInv.Cells(r, "A").Value
    Next r
        
    Application.ScreenUpdating = True
    
End Sub

 

[HighAndWilder]

Hello
I'm a VBA novice and normally can cobble something together but am stuck with this one.

I have a sheet called "Inventory Details" and a list of part numbers in cell A2 down, this will be a variable number of part numbers, I need each cell copied then pasted 6 times into a Sheet called " Routing Info" starting in A2 and the the next cell pasted 6 times below and so on.

Any assistance would be greatly appreciated.

"Inventory Details" Cells
View attachment 120419
" Routing Info" sheet final requirement
View attachment 120420

Thank you

Or this.

Private Sub subCopyParts()
Dim arr() As Variant
Dim i As Integer
Dim lngRow As Long
Dim ii As Integer

  With Worksheets("Inventory Details")
    arr = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
  End With
  
  lngRow = 2
  
  For i = 1 To UBound(arr)
    For ii = 1 To 6
      Worksheets("Routing Info").Range("A" & lngRow).Value = arr(i, 1)
      lngRow = lngRow + 1
    Next ii
  Next i
  
End Sub

 

[Multim]

Both Work great, Thank you Guys

 

[Joe4]

You are welcome.
Glad we were able to help!

 

[Multim]

Hi All

Re-opening this post to ask if the above code can be altered to paste until the last cell of data in column A?

Thanks in advance

Solved it, but thanks

 

[Joe4]

Re-opening this post to ask if the above code can be altered to paste until the last cell of data in column A?

My code (the one you marked as the solution) already does that, specifically this part here:

'   Find last row in column A with data on Inventory Detils sheet
    lr = wsInv.Cells(wsInv.Rows.Count, "A").End(xlUp).Row

If it is not working the way you want, please show us an example where it is not working.