Convert 2-Column Spreadsheet to Multi-Columns based on 1 Column

Hi

I have a 2-column spreadsheet, where the values in column 1 repeat but the values in column 2 are unique.

Column 1 Column 2
ADD Joe
ADD Pete
ADD Harry
ADD Tom
ADD Jenny
BEN Joe
BEN Pete
BEN Tom
BEN Jenny
CAD Joe
CAD Pete
CAD Tom
CAD Harry

I want to flip it so Column 1 becomes the Column headings for as many as needed (no repeats) and then the values of COlumn 2 fall in line where necessary.

ADD BEN CAD
Joe Joe Joe
Pete Pete Pete
Harry Harry
Tom Tom Tom
Jenny Jenny


I tried PIVOT TABLES, but only get this:

ADD BEN CAD
Joe
Pete
Harry
Tom
Jenny

(no matter how many times I edit this post, this last table doesn't appear correctly. The names are showing up as column 1 and ADD, BEN and CAD are showing as the headers for Columns 2 through 4. I hope this makes sense.)

The TRANSPOSE function didn't work either.

There are over 3,700 rows for this spreadsheet and can't even imagine attempting this manually! :-(

I'd really appreciate any help on this.

Thanks!
Jim

Try

Sub tranpose()
Dim cell As Range
Dim ValUnique As New Collection
Dim i As Integer
Dim LR As Long

LR = Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next
For Each cell In Range("A1:A" & LR)
    ValUnique.Add cell.Value, CStr(cell.Value)
Next cell

For i = 1 To ValUnique.Count
    Cells(1, i + 3) = ValUnique.Item(i)
Next i

Range("B1:B" & LR).Copy Range("D2:F2")
End Sub

A formula approach
Step 1: Copy Col A to E1, Copy Col B to F2
Step 2: Data tab> Remove Duplicates on E and then on F
Copy Unique values from E to G1:?1 using Paste Special > transpose
Step 3: In G2, dragged across and down, =IF(COUNTIFS($A$1:$A$13,G$1,$B$1:$B$13,$F2)>0,$F2,"")
Step 4: Copy, Paste Special Values over new table to remove formulas
See attachment

Nice code approach Jie

Originally Posted by ChemistB

Nice code approach Jie

More like I am too lazy to come up with a formula

Oh my bad. Hit Alt + F11 to open the VBA window, on the menu on top, click on insert > module. Then just copy and paste the code and hit F5 (or click on Macro and select the procedure and hit run) to run the macro.

I spoke too soon. I get the following when I run your code

Formula:

ADD	BEN	CAD

Joe	Joe	Joe

Pete	Pete	Pete

Harry	Harry	Harry

Tom	Tom	Tom

Jenny	Jenny	Jenny

Joe	Joe	Joe

Pete	Pete	Pete

Tom	Tom	Tom

Jenny	Jenny	Jenny

Joe	Joe	Joe

Pete	Pete	Pete

Tom	Tom	Tom

Harry	Harry	Harry

Somethings amiss.

Good catch. Just came back from lunch. Here try the revised code

Sub tranpose()
Dim cell As Range
Dim ValUnique As New Collection
Dim i As Integer
Dim LR As Long

LR = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
For Each cell In Range("A1:A" & LR)
    ValUnique.Add cell.Value, CStr(cell.Value)
Next cell

For i = 1 To ValUnique.Count
    Cells(1, i + 3) = ValUnique.Item(i)
Next i

Rows("1").Insert
Range("A1:B1") = Array("X", "Y")
Range("B1:B" & LR + 1).AdvancedFilter xlFilterCopy, , Range("D3"), True
Range("D3").Delete
Range("D3:D" & Cells(Rows.Count, 4).End(xlUp).Row).Copy Range("E3:F3")
Rows("1").Delete
End Sub

Maybe I misunderstand your question. Can you upload a sample file with what the final result should look like.

Give this a try

Sub abc()
 Dim i As Long
 Dim a, s
 
    a = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    With CreateObject("Scripting.Dictionary")
       .CompareMode = 1
       For i = 1 To UBound(a)
           If Not .Exists(a(i, 1)) Then
               .Item(a(i, 1)) = a(i, 1) & "," & a(i, 2)
           Else
               .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
           End If
       Next
       a = .Items
       For i = LBound(a) To UBound(a)
           s = Split(a(i), ",")
           Cells(1, 4 + i).Resize(UBound(s) + 1) = WorksheetFunction.Transpose(s)
       Next
    End With
 
End Sub

Heres as sample workbook

Transpose.xlsm

Nope, Harry shouldn't appear under BEN, and Jenny shouldn't appear under CAD. Unless my formulas are wrong

@JieJenn

Heres an update to your code that should work

Sub tranpose()
Dim cell As Range
Dim ValUnique As New Collection
Dim i As Integer
Dim LR As Long

LR = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
For Each cell In Range("A1:A" & LR)
    ValUnique.Add cell.Value, CStr(cell.Value)
Next cell

Rows("1").Insert
Range("A1:B1") = Array("X", "Y")
For i = 1 To ValUnique.Count
    Cells(1, i + 3) = ValUnique.Item(i)
    Range("A1:B" & LR + 1).AutoFilter Field:=1, Criteria1:=CStr(ValUnique.Item(i))
    Range("B2:B" & LR + 1).SpecialCells(xlCellTypeVisible).Copy Cells(2, i + 3)
Next i
Range("A1:B1").Delete Shift:=xlUp
End Sub