Option Explicit
Sub foo()
Dim sItems
Dim SData(1 To 19)
SData(1) = "4,9,10,21,35,47,64,72,74,75"
SData(2) = "4,9,10,21,33,41,47,57,60,72,74"
SData(3) = "3,4,10,11,21,32,33,35,60,69,74"
SData(4) = "3,4,7,10,21,33,37,47,57,69,75"
SData(5) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(6) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(7) = "4,7,9,10,11,32,35,41,69,74"
SData(8) = "3,4,10,21,32,37,47,64,69,72,75,77"
SData(9) = "3,7,11,33,35,37,41,47,64,75"
SData(10) = "4,6,9,10,15,21,31,47,72,74"
SData(11) = "6,9,13,21,22,31,49,52,63,64,75"
SData(12) = "9,10,12,21,22,47,49,52,64,72"
SData(13) = "9,10,12,21,22,47,49,52,64,72"
SData(14) = "9,10,12,21,22,47,49,52,64,72"
SData(15) = "6,9,10,13,21,49,52,63,72,74,75,79,80"
SData(16) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(17) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(18) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(19) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
sItems = 19

Combinations SData, sItems

End Sub


Sub Combinations(SData, sItems)
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim v4a As Variant, k As Long
Dim v5a As Variant, l As Long
Dim v6a() As Long
Dim bDone As Boolean, kk As Long
Dim sStr As String, sChr As String
Dim bPrintout As Boolean
Dim sArr As String, cnt1 As Long
Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Dim sh1 As Worksheet

Set sh1 = ActiveSheet

sArr = "{4,10;5,30;" & _
"6,120;7,1000;" & _
"8,11000;9,80000;" & _
"10,2000000}"
v5a = Evaluate(sArr)



Set rng1 = Range("W1:AK19")
ReDim v1(1 To sItems, 2)
i = 0
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
cnt = (Len(SData(j)) - Len(Replace(SData(j), ",", ""))) + 1
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next j
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
i = i + 1
cnt = v1(i, 1)
' Set rng = rw.Cells.Resize(1, cnt)
ReDim v(1 To cnt)
kk = 1
sStr = ""
For k = 1 To Len(SData(j))
sChr = Mid(SData(j), k, 1)
If sChr = "," Then
v(kk) = CLng(sStr)
sStr = ""
kk = kk + 1
Else
sStr = sStr & sChr
End If
Next k
If sStr < "" Then
v(kk) = sStr
End If
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next j


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next

cnt = 0

If lMax 2 Then
For i = 1 To tot
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
Next
ReDim v3a(1 To cnt, 1 To 11)
cnt = 0


For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a




v4a = sh1.Range("A1").CurrentRegion

For i = 1 To cnt ' ubound(v3a,1)
v3a(i, 11) = 0
For k = 1 To UBound(v4a, 1)
cnt1 = 0
For j = 1 To 10
For l = LBound(v4a, 2) To UBound(v4a, 2)
If v3a(i, j) = v4a(k, l) Then
cnt1 = cnt1 + 1
Exit For
End If
Next l
Next j
For m = LBound(v5a, 1) To UBound(v5a, 1)
If cnt1 = v5a(m, LBound(v5a, 2)) Then
v3a(i, 11) = v3a(i, 11) + v5a(m, UBound(v5a, 2))
Exit For
End If
Next m
Next k
Next i

bAscending = False
QuickSort v3a, 11, LBound(v3a, 1), UBound(v3a, 1), bAscending

' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
If UBound(v3a, 1) <= Rows.Count Then
sh.Range("A1").Resize(cnt, 11).Value = v3a
Else
ReDim v6a(1 To 65536, 1 To 11)
For i = 1 To 65536
For j = 1 To 11
v6a(i, j) = v3a(i, j)
Next j
Next i
sh.Range("A1").Resize(65536, 11).Value = v6a
End If
End If

Else
MsgBox "Max duplicates is 2, do nothing"
End If ' lMax 2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, l, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = l
j = R
X = SortArray((l + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) X And i < R)
i = i + 1
Wend
While (X SortArray(j, col) And j l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (l < j) Then Call QuickSort(SortArray, col, l, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

--
Regards,
Tom Ogilvy

"Maxi" wrote in message
oups.com...
Thank you.

For the other request, I think we need two parameters:
1. The actual array with comma seperated strings of numbers
2. The number of items in that string array

I have both ready and I need to call your code through my code like
this:

Combinations SData,Sitems

where SData is the array and Sitems will have the count 19

Thanks
Maxi

Tom Ogilvy wrote:
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
if Ubound(v3a,1) <= rows.count then
sh.Range("A1").Resize(cnt, 11).Value = v3a
else
dim v6a(1 to 65536, 1 to 11) as Long
for i = 1 to 65536
for j = 1 to 11
v6a(i,j) = v3a(i,j)
next i
next j
sh.Range("A1").Resize(65536,11).Value = v6a
end if
End If

I will look at you new request later.


--
Regards,
Tom Ogilvy