Transpose Code Needed Please

[Dazzawm]

I have sheet1 as laid out below. I need a transpose code I think so that there is only 1 number from column A but all the numbers from C going horizontal on sheet 2

I am happy to make a donation to charity for a quick solution on this one.

Excel 2010

	A	B	C
ECAU1131TA	BOSAL	090-744
ECAU1131TA	BOSAL	099-602
ECAU1135TA	BOSAL	090-756
ECAU1135TA	BOSAL	099-815
ECAU5000	BOSAL	098-031
ECAU5000	BOSAL	098-041
ECAU5000	BOSAL	099-031
ECAU5000	BOSAL	099-041

<tbody>
[TD="align: center"]15[/TD]

[TD="align: center"]16[/TD]

[TD="align: center"]17[/TD]

[TD="align: center"]18[/TD]

[TD="align: center"]19[/TD]

[TD="align: center"]20[/TD]

[TD="align: center"]21[/TD]

[TD="align: center"]22[/TD]

</tbody>

Sheet1​

This how I would like it to look on sheet2 please

Excel 2010

	A	B	C	D	E
BOSAL	BOSAL	BOSAL	BOSAL
ECAU1131TA	090-744	099-602
ECAU1135TA	090-756	099-815
ECAU5000	098-031	098-041	099-031	099-041

<tbody>
[TD="align: center"]1[/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]

</tbody>

Sheet2​

 

[MickG]

Try this for your data starting sheet1 "A1" with results starting "A1" on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG07Nov11
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Sheets("Sheet1").Cells(1).CurrentRegion.Resize(, 3)
ReDim nray(1 To UBound(Ray, 1), 1 To 3)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
c = 1: nray(1, 2) = Ray(1, 2)
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not .Exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            nray(c, 1) = Ray(n, 1)
            nray(c, 2) = Ray(n, 3)
            .Add Ray(n, 1), Array(c, 2)
    
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Ray(n, 1))
            Q(1) = Q(1) + 1
            [COLOR="Navy"]If[/COLOR] Q(1) > UBound(nray, 2) [COLOR="Navy"]Then[/COLOR] ReDim Preserve _
            nray(1 To UBound(Ray, 1), 1 To Q(1))
           nray(1, Q(1)) = Ray(1, 2): nray(Q(0), Q(1)) = Ray(n, 3)
        .Item(Ray(n, 1)) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(nray, 2))
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Dazzawm]

Thanks Mick works perfect. Could there be a header of each that is in column B? Like in the sheet 2 example please?

Excel 2010

	A	B	C
ECAR1013TA	BOSAL	098-749
ECAR1013TA	Test	099-749

<tbody>
[TD="align: center"]5[/TD]

[TD="align: center"]6[/TD]

</tbody>

Sheet1​

Excel 2010
	A	B	C
1		BOSAL	Test
2	ECAR1013TA	098-749	099-749
Sheet2

 

[Dazzawm]

Actually I run the code again and it seemed to add them!?

 

[MickG]

Try changing line below:- (From 1 to n)
NB:- if column "B" data has a list of different Texts, then this result might not be what you want !!!!

 nray(1, Q(1)) = Ray[B][COLOR=#FF0000](n,[/COLOR][/B] 2): nray(Q(0), Q(1)) = Ray(n, 3)

 

[Dazzawm]

Sorry to be a pain Mick. My Director has just told me he doesn't want the headers from column B on sheet 2. I tried doing a clear contents of row 1 but it came up with a 400 error?

 

[MickG]

Remove lines shown in red:-

Sub Test()
Dim Rng As Range, Dn As Range, n As Long, Q As Variant, Ray As Variant, c As Long
Ray = Sheets("Sheet1").Cells(1).CurrentRegion.Resize(, 3)
ReDim nray(1 To UBound(Ray, 1), 1 To 3)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[B][COLOR=#FF0000]'c = 1:[/COLOR][/B]
For n = 1 To UBound(Ray, 1)
    If Not .Exists(Ray(n, 1)) Then
            c = c + 1
            nray(c, 1) = Ray(n, 1)
         [B][COLOR=#FF0000]   'nray(1, 2) = Ray(1, 2)[/COLOR][/B]
            nray(c, 2) = Ray(n, 3)
            .Add Ray(n, 1), Array(c, 2)
    Else
        Q = .Item(Ray(n, 1))
            Q(1) = Q(1) + 1
            If Q(1) > UBound(nray, 2) Then ReDim Preserve _
            nray(1 To UBound(Ray, 1), 1 To Q(1))
           [B][COLOR=#FF0000]' nray(1, Q(1)) = Ray(n, 2)[/COLOR][/B]
            nray(Q(0), Q(1)) = Ray(n, 3)
        .Item(Ray(n, 1)) = Q
End If
Next
End With
With Sheets("Sheet2").Range("A1").Resize(c, UBound(nray, 2))
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
End With
End Sub

 

[Dazzawm]

Thanks for everything Mick. Can you send me a link please.

 

[MickG]

You're welcome