Transpose Data in a Different Format

[Stephen_IV]

I am trying to Transpose Data in a Different Format, please see below. I am trying to take the data from columns A,B, and C and put it into Columns E:K. Any help would be appreciated. Thanks in advance Stephen.

Book2
	A	B	C	D	E	F	G	H	I	J	K
1	ID	Class	Needs			1	2	3	4	5	6
2	777	1	6,14,15		777	6,14,15	6,14,15	5,14,15	5,14,15	5,21,22	5,15,18
3	777	2	6,14,15		888	14,15,26	14,15	14,15	14,15	14,15	14,15
4	777	3	5,14,15		999	14,15		14,15	14,15	14,15	14,15
5	777	4	5,14,15		444	12,13,16		12,13,17		12,13,18
6	777	5	5,21,22
7	777	6	5,15,18
8	888	1	14,15,26
9	888	2	14,15
10	888	3	14,15
11	888	4	14,15
12	888	5	14,15
13	888	6	14,15
14	999	1	14,15
15	999	3	14,15
16	999	4	14,15
17	999	5	14,15
18	999	6	14,15
19	444	1	12,13,16
20	444	3	12,13,17
21	444	5	12,13,18
Sheet1

 

[Stephen_IV]

Bump

 

[MickG]

Try this :- Results start "E1"

[COLOR="Navy"]Sub[/COLOR] MG14Apr07
[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]
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 7)
[COLOR="Navy"]For[/COLOR] Ac = 1 To 7
ray(1, Ac) = IIf(Ac = 1, "ID/Class", Ac - 1)
[COLOR="Navy"]Next[/COLOR] Ac
n = 1
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.value) [COLOR="Navy"]Then[/COLOR]
        n = n + 1
        .Add Dn.value, n
        ray(n, 1) = Dn.value: ray(n, Dn.Offset(, 1) + 1) = Dn.Offset(, 2)
    [COLOR="Navy"]Else[/COLOR]
         ray(.Item(Dn.value), 1) = Dn.value: ray(.Item(Dn.value), Dn.Offset(, 1) + 1) = Dn.Offset(, 2)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
Range("E1").Resize(.Count + 1, 7) = ray
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Stephen_IV]

Thank you so much MickG,

Worked perfect!