Try this:
Option Explicit
Sub TransposeWIP()
Dim Sizes As Range, Itms As Range
Dim SzRws As Long, Rw As Long
'Setup
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'clear output sheet if it exists
If Evaluate("ISREF(Results!A1)") Then Sheets("Results").Delete
'duplicate activesheet to create new output sheet
ActiveSheet.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Results"
'insert new columns and clear WIP totals
Range("AM:AN").Insert xlShiftToRight
On Error Resume Next
Range("AL:AL").SpecialCells(xlConstants, xlNumbers).ClearContents
On Error GoTo 0
'Sizes to copy/transpose
Set Sizes = Range("AP2:AY2")
SzRws = 10
'Rows to process
Set Itms = Range("F:F").SpecialCells(xlConstants, xlNumbers)
'Loop each row from the bottom up inserting values needed
For Rw = Itms.Rows.Count + 2 To 3 Step -1
Range("A" & Rw).Offset(1).Resize(SzRws - 1).EntireRow.Insert xlShiftDown
Range("AM" & Rw).Resize(SzRws).Value = _
Application.WorksheetFunction.Transpose(Sizes)
Range("AN" & Rw).Resize(SzRws).Value = _
Application.WorksheetFunction.Transpose(Range("AP" & Rw, "AY" & Rw))
Range("E" & Rw, "G" & Rw).Resize(SzRws).Value = _
Range("E" & Rw, "G" & Rw).Value
Range("AG" & Rw, "AK" & Rw).Resize(SzRws).Value = _
Range("AG" & Rw, "AK" & Rw).Value
Next Rw
'Cleanup
Application.ScreenUpdating = True
End Sub
Bookmarks