This is a routine a developed a while back..
it's much faster then recursive techniques i've come across.
Remember that combinations grow very quickly...
and that excel can hold only 65000 rows..
The largest I could create was a Bytearray of 5m combinations.
(26/10 or 25/12) (with a slightly modified version of the routine.
(takes 30 secs on my laptop)
The routine posted will give you a variant array.. which takes more
memory but can be dumped in Excel with more ease..
These are numbers you can expect...
0 1 2 3 4 5 6 7 8 9
1 1
2 2 1
3 3 3 1
4 4 6 4 1
5 5 10 10 5 1
6 6 15 20 15 6 1
7 7 21 35 35 21 7 1
8 8 28 56 70 56 28 8 1
9 9 36 84 126 126 84 36 9 1
10 10 45 120 210 252 210 120 45 10
11 11 55 165 330 462 462 330 165 55
12 12 66 220 495 792 924 792 495 220
13 13 78 286 715 1287 1716 1716 1287 715
14 14 91 364 1001 2002 3003 3432 3003 2002
15 15 105 455 1365 3003 5005 6435 6435 5005
16 16 120 560 1820 4368 8008 11440 12870 11440
17 17 136 680 2380 6188 12376 19448 24310 24310
18 18 153 816 3060 8568 18564 31824 43758 48620
19 19 171 969 3876 11628 27132 50388 75582 92378
20 20 190 1140 4845 15504 38760 77520 125970 167960
21 21 210 1330 5985 20349 54264 116280 203490 293930
This will dump the details..
Sub CreateCombinations()
'keepITcool 2004/11/01
Dim rSrc As Range, rDst As Range, rITM As Range
Dim cItm As Collection, vItm()
Dim aIdx() As Byte, vRes()
Dim nItm&, nDim&, nCnt&
Dim r&, c&
Set rSrc = Application.InputBox("Select the Source data", Type:=8)
If rSrc Is Nothing Then
Beep
Exit Sub
End If
'Create a collection of unique items in range.
Set cItm = New Collection
On Error Resume Next
For Each rITM In rSrc.Cells
If rITM <> vbNullString Then cItm.Add rITM.Value2, CStr(rITM.Value2)
Next
nItm = cItm.Count
ReDim vItm(1 To nItm)
For r = 1 To nItm
vItm(r) = cItm(r)
Next
On Error GoTo 0
Let nDim = Application.InputBox("Size of 'groups' ", Type:=1)
If nDim < 1 Or nDim > nItm Then
Beep
Exit Sub
End If
'Get the number of combinations
nCnt = Application.Combin(nItm, nDim)
If nCnt > Rows.Count Then
MsgBox nCnt & " combinations...Wont fit
", vbCritical
'Exit Sub
End If
'Create the index array
ReDim aIdx(0 To 2, 1 To nDim) As Byte
'Create the result array
ReDim vRes(1 To nCnt, 1 To nDim)
'min on first row, max on last row
For c = 1 To nDim
aIdx(0, c) = c
aIdx(2, c) = nItm - nDim + c
Next
For r = 2 To nCnt - 1
aIdx(1, nDim) = aIdx(0, nDim) + 1
For c = 1 To nDim - 1
If aIdx(0, c + 1) = aIdx(2, c + 1) Then
aIdx(1, c) = aIdx(0, c) + 1
Else
aIdx(1, c) = aIdx(0, c)
End If
Next
For c = 2 To nDim
If aIdx(1, c) > aIdx(2, c) Then
aIdx(1, c) = aIdx(1, c - 1) + 1
End If
Next
For c = 1 To nDim
aIdx(0, c) = aIdx(1, c)
vRes(r, c) = vItm(aIdx(1, c))
Next
Next
dump:
Set rDst = Application.InputBox("Select the Destination Range", Type:=
8)
If rDst Is Nothing Then
Beep
Exit Sub
End If
If Rows.Count - rDst.Row < nCnt Then
Stop
ElseIf Columns.Count - rDst.Column < nDim Then
Stop
End If
With rDst
.CurrentRegion.Clear
.Resize(nCnt, nDim) = vRes
End With
End Sub
keepITcool
< email : keepitcool chello nl (with @ and .) >
< homepage:
http://members.chello.nl/keepitcool >
