Assuming headers in row 1 try this
Code:
Option Explicit
Sub ReArrangeAssemblyParts()
Dim c 'array of unique assembly nums
Dim rng1 As Range 'original range of assembly nums
Dim cel1 As Range 'individual cells in rng1
Dim rng2 As Range 'range where unique assembly nums reside
Dim cel2 As Range 'individual cells in rng2
Dim Lrow As Long 'last row used in col A
Dim i As Long 'column offsets for parts
'make sure on right sheet
Sheets("Sheet1").Activate
Lrow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = Range("A2:A" & Lrow)
With CreateObject("scripting.dictionary")
For Each c In rng1.Value
.Item(c) = 1
Next c
Range("D2").Resize(.Count) = Application.Transpose(.keys)
End With
Set rng2 = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
For Each cel2 In rng2
i = 1
For Each cel1 In rng1
If cel1.Value = cel2.Value Then
cel2.Offset(0, i).Value = cel1.Offset(0, 1).Value
i = i + 1
End If
Next cel1
Next cel2
End Sub
Bookmarks