[COLOR="Navy"]Sub[/COLOR] MG01Dec10
'[COLOR="Green"][B]Fast Array[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, P [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, M [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Tot [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] temp1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Temp2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Temp3 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] fd [COLOR="Navy"]As[/COLOR] Boolean, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]For[/COLOR] col = 1 To 2
[COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, col).Value) [COLOR="Navy"]Then[/COLOR]
Dic(Dn.Value).Add (Dn.Offset(, col).Value), col
[COLOR="Navy"]Else[/COLOR]
[COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Item(Dn.Offset(, 1).Value) = col [COLOR="Navy"]Then[/COLOR]
Dic(Dn.Value).Remove (Dn.Offset(, col).Value)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] col
[COLOR="Navy"]Next[/COLOR] Dn
M = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
Tot = Tot + M
c = 0
ReDim Ray(1 To Dic(K).Count, 1 To 3)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] Dic(K)
c = c + 1
Ray(c, 1) = K
Ray(c, 2) = P
Ray(c, 3) = Dic(K)(P)
[COLOR="Navy"]Next[/COLOR] P
[COLOR="Navy"]For[/COLOR] i = 1 To UBound(Ray, 1)
[COLOR="Navy"]For[/COLOR] j = i To UBound(Ray)
[COLOR="Navy"]If[/COLOR] Ray(j, 2) < Ray(i, 2) [COLOR="Navy"]Then[/COLOR]
temp1 = Ray(i, 1)
Temp2 = Ray(i, 2)
Temp3 = Ray(i, 3)
Ray(i, 1) = Ray(j, 1)
Ray(i, 2) = Ray(j, 2)
Ray(i, 3) = Ray(j, 3)
Ray(j, 1) = temp1
Ray(j, 2) = Temp2
Ray(j, 3) = Temp3
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] j
[COLOR="Navy"]Next[/COLOR] i
M = 1
ReDim nRay(1 To UBound(Ray, 1) / 2, 1 To 3)
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
[COLOR="Navy"]If[/COLOR] fd = False [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]If[/COLOR] Ray(n, 3) = 1 [COLOR="Navy"]Then[/COLOR]
fd = True
nRay(M, 1) = Ray(n, 1)
nRay(M, 2) = CDate(Ray(n, 2))
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] fd = True [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] True
[COLOR="Navy"]Case[/COLOR] n = UBound(Ray, 1)
nRay(M, 3) = CDate(Ray(n, 2))
fd = False
[COLOR="Navy"]Case[/COLOR] Ray(n, 3) = 2 And Ray(n + 1, 3) = 1
nRay(M, 3) = CDate(Ray(n, 2))
M = M + 1
fd = False
[COLOR="Navy"]End[/COLOR] Select
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
.Range("A1").Offset(Tot).Resize(M, 3) = nRay
.Range("A1").Resize(, 3) = Array("Cust", "Start", "End")
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]