Transpose Data with multiple entries

[gmath]

I am a little stuck right now, I know there has to be an easy way to do this, but I'm a little out of practice with my VBA, and developing Macros. I was hoping that utilizing Pivot Tables would get me the information I need in the format I would like it, but unfortunately it didn't do what I am looking for. I have a spreadsheet with what I have reduced to 2 columns. Column A has a list of Assembly Numbers, and Column B has a list of Part Numbers used in those assemblies. I want to take column A and remove the duplicates, and take the information in column B and have the Part Numbers that are associated with the assembly "transposed" into the row that lists the assembly.

 

[NoS]

Assuming headers in row 1 try this

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

 

[Hercules1946]

Hello Gmath
I know you've posted in the VBA forum, but there is also a solution to this using formulae:

1. Use the Advanced Filter (Data tab) to generate a list of unique entries from col A2:, and copy to col D2: (takes a few seconds).
2. Copy the formula below to Cell E2. Then copy E2 down and across, creating a block deep enough to cover all the unique assembly codes
and wide enough for the assembly with the largest number of parts. E2115 in the example.
=IF(COUNTIF($A$2:$A$1005,$D2)>COLUMN(A$1)-1,INDEX($B$2:$B$1005,MATCH($D2,$A$2:$A$1005,0)+COLUMN(A$1)-1),"")

Adjust the arrays to suit your dataset.

 

[gmath]

Thanks for your help. I really appreciate it.