[COLOR="Navy"]Sub[/COLOR] MG20Jun09
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, R [COLOR="Navy"]As[/COLOR] Variant, Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] St, Sa [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
Ray = ActiveSheet.Cells(1).CurrentRegion
ReDim nRay(1 To UBound(Ray, 1) * 3, 1 To UBound(Ray, 2))
[COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
c = 1
[COLOR="Navy"]With[/COLOR] CreateObject("System.Collections.ArrayList")
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
[COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
Dic.Add Ray(n, Ac), n
.Add Ray(n, Ac)
[COLOR="Navy"]Else[/COLOR]
Dic(Ray(n, Ac)) = Dic(Ray(n, Ac)) & "," & n
.Add Ray(n, Ac)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
.Sort: .Reverse
R = .toarray: c = 1
nRay(1, Ac - 1) = Ray(1, Ac)
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]For[/COLOR] Sa = 0 To UBound(R)
[COLOR="Navy"]If[/COLOR] Not Temp = R(Sa) [COLOR="Navy"]Then[/COLOR]
Sp = Split(Dic(R(Sa)), ",")
[COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
c = c + 1
nRay(c, Ac - 1) = Ray(Sp(n), 1)
c = c + 1
nRay(c, Ac - 1) = R(Sa)
[COLOR="Navy"]Next[/COLOR] n
Temp = R(Sa)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Sa
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Set[/COLOR] Rng = Sheets("Sheet2").Range("A1").Resize(c, UBound(Ray, 2) - 1)
[COLOR="Navy"]With[/COLOR] Rng
.Value = nRay
.Borders.Weight = 2
.Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
Newcols Rng, Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] Newcols(nRng [COLOR="Navy"]As[/COLOR] Range, sRay)
[COLOR="Navy"]Dim[/COLOR] rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] fCol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(sRay, 1): Dic(sRay(n, 1)) = Dic.Count: [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]For[/COLOR] Ac = 1 To nRng.Columns.Count
[COLOR="Navy"]For[/COLOR] rw = 2 To nRng.Rows.Count [COLOR="Navy"]Step[/COLOR] 2
[COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dic(nRng(rw, Ac).Value)
[COLOR="Navy"]Case[/COLOR] 2, 6, 15, 19, 20, 22, 24, 27, 34, 35, 36, 37, 38, 39, 40, 43, 44, 45, 46, 51, 52: fCol = 1
[COLOR="Navy"]Case[/COLOR] Else: fCol = 2
[COLOR="Navy"]End[/COLOR] Select
nRng(rw, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
nRng(rw + 1, Ac).Interior.ColorIndex = Dic(nRng(rw, Ac).Value)
nRng(rw, Ac).Font.ColorIndex = fCol
nRng(rw + 1, Ac).Font.ColorIndex = fCol
[COLOR="Navy"]Next[/COLOR] rw
[COLOR="Navy"]Next[/COLOR] Ac
nRng.Font.Bold = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]