[COLOR=Navy]Sub[/COLOR] MG19Jun31
[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] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object, Ray [COLOR=Navy]As[/COLOR] Variant, Sp [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] R [COLOR=Navy]As[/COLOR] Variant, aN [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] bN [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] cN [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] Ray1, a [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] aa [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] R1 [COLOR=Navy]As[/COLOR] Range, R2 [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy] Set[/COLOR] Rng = Range("A1:F5,A8:F12")
Ray = Array(Array(0, 1), Array(1, 1), Array(1, 0), Array(1, -1), Array(0, -1), Array(-1, -1), Array(-1, 0), Array(-1, 1))
[COLOR=Navy]For[/COLOR] n = 1 To Rng.Areas.Count
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng.Areas(n)
[COLOR=Navy]For[/COLOR] a = 0 To UBound(Ray)
[COLOR=Navy]On[/COLOR] [COLOR=Navy]Error[/COLOR] [COLOR=Navy]Resume[/COLOR] [COLOR=Navy]Next[/COLOR]
[COLOR=Navy]Set[/COLOR] R1 = Dn.Offset(Ray(a)(0), Ray(a)(1))
[COLOR=Navy]For[/COLOR] aa = 0 To UBound(Ray)
[COLOR=Navy]Set[/COLOR] R2 = R1.Offset(Ray(aa)(0), Ray(aa)(1))
[COLOR=Navy]If[/COLOR] Not Intersect(Rng.Areas(n), R1) [COLOR=Navy]Is[/COLOR] Nothing And Not Intersect(Rng.Areas(n), R2) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
[COLOR=Navy]If[/COLOR] Not Dic.exists(Dn.Value & "," & R1 & "," & R2) [COLOR=Navy]Then[/COLOR]
Dic.Add (Dn.Value & "," & R1 & "," & R2), Nothing
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] aa
[COLOR=Navy]On[/COLOR] [COLOR=Navy]Error[/COLOR] GoTo 0
[COLOR=Navy]Next[/COLOR] a
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]If[/COLOR] n = 1 [COLOR=Navy]Then[/COLOR] Ray1 = Application.Transpose(Dic.Keys)
[COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Ray1
Sp = Split(R, ",")
[COLOR=Navy]For[/COLOR] aN = -1 To 1
[COLOR=Navy]For[/COLOR] bN = -1 To 1
[COLOR=Navy]For[/COLOR] cN = -1 To 1
[COLOR=Navy]If[/COLOR] Dic.exists(Sp(0) + aN & "," & Sp(1) + bN & "," & Sp(2) + cN) [COLOR=Navy]Then[/COLOR]
c = c + 1
Cells(c, "H") = R: Cells(c, "I") = Sp(0) + aN & "," & Sp(1) + bN & "," & Sp(2) + cN
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] cN
[COLOR=Navy]Next[/COLOR] bN
[COLOR=Navy]Next[/COLOR] aN
[COLOR=Navy]Next[/COLOR] R
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]