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!