[COLOR="Navy"]Sub[/COLOR] MG13Oct28
[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] Dic [COLOR="Navy"]As[/COLOR] Object, Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, nRay [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Cells(1).CurrentRegion
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]With[/COLOR] CreateObject("System.Collections.ArrayList")
[COLOR="Navy"]For[/COLOR] Ac = 1 To 3 [COLOR="Navy"]Step[/COLOR] 2
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
[COLOR="Navy"]If[/COLOR] Not .Contains(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR] .Add Ray(n, Ac)
[COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
ReDim TRay(1 To 3)
TRay(Ac) = Ray(n, Ac + 1)
Dic.Add Ray(n, Ac), TRay
[COLOR="Navy"]Else[/COLOR]
Q = Dic(Ray(n, Ac))
Q(Ac) = Ray(n, Ac + 1)
Dic(Ray(n, Ac)) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Ac
.Sort: nRay = .toarray
ReDim nSort(1 To UBound(Ray, 1) * 2, 1 To UBound(Ray, 2))
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay)
c = c + 1
[COLOR="Navy"]If[/COLOR] Dic(nRay(n))(1) <> "" [COLOR="Navy"]Then[/COLOR]
nSort(c, 1) = nRay(n)
nSort(c, 2) = Dic(nRay(n))(1)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Dic(nRay(n))(3) <> "" [COLOR="Navy"]Then[/COLOR]
nSort(c, 3) = nRay(n)
nSort(c, 4) = Dic(nRay(n))(3)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Range("G1").Resize(c, UBound(Ray, 2))
.Value = nSort
.Borders.Weight = 2
.HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]