Transpose Data with multiple entries

gmath

New member
Joined
Oct 8, 2013
Messages
2
Reaction score
0
Points
0
Location
Atlanta, GA
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

New member
Joined
Jan 17, 2013
Messages
832
Reaction score
0
Points
0
Location
British Columbia
Excel Version(s)
Excel 2010
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
 

Hercules1946

New member
Joined
Mar 22, 2013
Messages
794
Reaction score
0
Points
0
Location
York, England
Excel Version(s)
2010
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. E2:p115 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.
 

Attachments

  • AssemParts.xlsm
    40.7 KB · Views: 18
Last edited:
Top