Option Explicit
[COLOR="Navy"]Dim[/COLOR] Ray()
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Sub[/COLOR] MG27May11
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] rRng [COLOR="Navy"]As[/COLOR] Range, p, N, nRay, w [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] vElements, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Dic(Dn.Value) = Empty
[COLOR="Navy"]Next[/COLOR] Dn
nRay = Application.Transpose(Dic.Keys)
Dic.RemoveAll
[COLOR="Navy"]For[/COLOR] N = 2 To UBound(nRay)
vElements = Application.Transpose(nRay)
ReDim vresult(1 To N)
Call CombinationsNP(vElements, CInt(N), vresult, lRow, 1, 1)
[COLOR="Navy"]Next[/COLOR] N
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[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
Dic(Dn.Value).Add (Dn.Offset(, 1).Value), Nothing
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, Sp [COLOR="Navy"]As[/COLOR] Variant, g [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]For[/COLOR] N = 0 To UBound(Ray)
Sp = Split(Ray(N), ",")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
fd = True
[COLOR="Navy"]For[/COLOR] ac = 0 To UBound(Sp)
[COLOR="Navy"]If[/COLOR] Not Dic(k).exists(Sp(ac)) [COLOR="Navy"]Then[/COLOR]
fd = False
[COLOR="Navy"]Exit[/COLOR] For
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] ac
[COLOR="Navy"]If[/COLOR] fd = True [COLOR="Navy"]Then[/COLOR]
g = g + 1
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]If[/COLOR] Not g = 0 [COLOR="Navy"]Then[/COLOR]
w = w + 1
Cells(w, "D") = Ray(N) & " = " & g
g = 0
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] N
c = 0
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] CombinationsNP(vElements [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] iElement [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] iIndex [COLOR="Navy"]As[/COLOR] Integer)
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]For[/COLOR] i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
[COLOR="Navy"]If[/COLOR] iIndex = p [COLOR="Navy"]Then[/COLOR]
lRow = lRow + 1
ReDim Preserve Ray(c)
Ray(c) = Join(vresult, ",")
c = c + 1
[COLOR="Navy"]Else[/COLOR]
Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]