Option Explicit
[COLOR="Navy"]Dim[/COLOR] sRay() [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Sub[/COLOR] Dups()
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nray(), Q [COLOR="Navy"]As[/COLOR] Variant, Rng [COLOR="Navy"]As[/COLOR] Range, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = ActiveSheet.Range("A1").CurrentRegion.Resize(, 2)
[COLOR="Navy"]With[/COLOR] Rng
.Sort Key1:=.Range("A1"), Key2:=.Range("B1"), Header:=xlYes
[COLOR="Navy"]End[/COLOR] With
p = 2
Ray = Rng.Value
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
[COLOR="Navy"]If[/COLOR] Not .Exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
ReDim nray(1 To 1)
nray(1) = Ray(n, 2)
.Add Ray(n, 1), nray
[COLOR="Navy"]Else[/COLOR]
Q = .Item(Ray(n, 1))
ReDim Preserve Q(1 To UBound(Q) + 1)
Q(UBound(Q)) = Ray(n, 2)
.Item(Ray(n, 1)) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Dim[/COLOR] rRng [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] vElements, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .Keys
vElements = .Item(K)
ReDim vresult(1 To p)
Call CombinationsNP(vElements, CInt(p), vresult, lRow, 1, 1)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
Call nCount(sRay)
[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 sRay(1 To 2, 1 To lRow)
sRay(1, lRow) = vresult(1)
sRay(2, lRow) = vresult(2)
[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]
[COLOR="Navy"]Sub[/COLOR] nCount(R)
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
c = 1
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(R, 2)
txt = R(1, n) & "," & R(2, n)
[COLOR="Navy"]If[/COLOR] Not .Exists(txt) [COLOR="Navy"]Then[/COLOR]
c = c + 1
.Add txt, c
Cells(c, "C") = txt: Cells(c, "D") = 1
[COLOR="Navy"]Else[/COLOR]
Cells(.Item(txt), "D") = Cells(.Item(txt), "D") + 1
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
