transpose data of duplicate cells

[trustmywords]

the source is like this.

col1 col2
220 bat
211 van
223 fan
220 cat
211 tin

I like the result to be like
col1 col2 col3
220 bat cat
211 van tin
223 fan

Can anyone suggest me a macro for this. I have 10,000 rows like this.

thanks

 

[mirabeau]

the source is like this.

col1 col2
220 bat
211 van
223 fan
220 cat
211 tin

I like the result to be like
col1 col2 col3
220 bat cat
211 van tin
223 fan

Can anyone suggest me a macro for this. I have 10,000 rows like this.

thanks

Try this macro.

It assumes your data are in columns A and B, with headers.

Easily modified if other data layout.

Sub relist()
Dim d As Object
Dim a, u(), c()
Dim i&, n&
Set d = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion.Resize(, 2)
n = UBound(a, 1)
For i = 2 To n
    If Not d.exists(a(i, 1)) Then
        d.Add a(i, 1), d.Count + 1
        ReDim Preserve c(1 To d(a(i, 1)))
        ReDim Preserve u(1 To n, 1 To d(a(i, 1)))
        c(d(a(i, 1))) = 2
        u(1, d(a(i, 1))) = a(i, 1)
        u(2, d(a(i, 1))) = a(i, 2)
    Else
        c(d(a(i, 1))) = c(d(a(i, 1))) + 1
        u(c(d(a(i, 1))), d(a(i, 1))) = a(i, 2)
    End If
Next i
Range("D2").Resize(d.Count, n) = Application.Transpose(u)
End Sub

 

[MrVillareal]

try

Excel 2010
	A	B	C
1	220	bat
2	211	van
3	223	fan
4	220	cat
5	211	tin
6
7
8
9	220	bat	cat
10	211	van	tin
11	223	fan
Sheet2

Cell Formulas
Range	Formula
A9	{=IFERROR(INDEX($A$1:$A$5,SMALL(IF(FREQUENCY(MATCH($A$1:$A$5,$A$1:$A$5,0),MATCH($A$1:$A$5,$A$1:$A$5,0)),ROW($A$1:$A$5)-ROW($A$1)+1),ROWS(A$9:A9))),"")}
B9	{=IFERROR(INDEX($B$1:$B$5,SMALL(IF($A$1:$A$5=$A9,ROW($B$1:$B$5)-ROW($B$1)+1),COLUMNS($B9:B9))),"")}
Press CTRL+SHIFT+ENTER to enter array formulas.

 

[MrVillareal]

sorry I provided a formula

 

[mirabeau]

I've realized that the code in Post #2 may give an error if using Excel 2003 or earlier.

The following version shouldn't have that problem, and is somewhat more efficient anyway.

Sub relist2()
Dim d As Object
Dim a, u(), c()
Dim i&, n&, e
Set d = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion.Resize(, 2)
n = UBound(a, 1)
For i = 2 To n
    e = a(i, 1)
    If Not d.exists(e) Then
        d.Add e, d.Count + 1
        ReDim Preserve c(1 To d(e))
        ReDim Preserve u(1 To n, 1 To d(e))
        c(d(e)) = 2
        u(1, d(e)) = e
        u(2, d(e)) = a(i, 2)
    Else
        c(d(e)) = c(d(e)) + 1
        u(c(d(e)), d(e)) = a(i, 2)
End If
If c(d(e)) > k Then k = c(d(e))
Next i
Range("D2").Resize(d.Count, k) = Application.Transpose(u)
End Sub