Thread: Transpose cant work

Not really good with formula but try this code. I think it might do the trick

Sub Test()
Dim LR As Long: LR = Cells(Rows.Count, 1).End(xlUp).Row
Dim x As Long, i As Long, j As Long
Columns("D:L").Clear

Range("A3:A" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D3"), Unique:=True
Range("D3").Delete

    For i = 3 To Cells(Rows.Count, 4).End(xlUp).Row
    x = 0
        For j = 3 To LR
            If Cells(i, 4) = Cells(j, 1) Then
                Cells(i, 5 + x) = Cells(j, 2)
                x = x + 1
            End If
        Next j
    Next i

End Sub

or a pivot table will do the trick