On Jul 4, 12:35*pm, "joeu2004" wrote:
Errata....

I wrote:
The macro below is a brute force approach.
It consumes a significant amount of memory.

Oops. *What I posted had some vestiges of a design that permitted me to see
all of the combinations. *It is not necessary to retain all combinations in
memory. *That results in a __huge__ savings in memory.

The following implementation also includes some other improvements.

1. With limSubset, I put a cap on the memory for the number of qualified
combinations. *This constant is currently set to 10,000. *That is probably
more than sufficient for any reasonable maxCombin.

2. With promptUser, I make it optional to use the Input worksheet and prompt
the user for nData, nSelect and maxMatch. *Alternatively, these values are
read from cells(1,1) of outRng, which works well if the data set is always
the integers from 1 to nData.

-----

Option Explicit

' set to False if inRng is not integer
#Const dataIsLong = True

' set to False if data is always 1 to N and
' nData, nSelect, nMatch come from outRng
#Const promptUser = False

Sub combinKofN()
Const limSubset As Long = 10000
Dim nData As Long, nSelect As Long
Dim maxCombin As Long, nCombin As Long
Dim maxSubset As Long, nSubset As Long
Dim maxMatch As Long, nMatch As Long
Dim i As Long, j As Long, k As Long
Dim inRng As Range, outRng As Range
Dim st0 As Double, st As Double
#If dataIsLong Then
* *Dim x As Long
#Else
* *Dim x
#End If

Application.StatusBar = ""
'On Error GoTo terminate

Set outRng = Sheets("output").Range("f7")

#If Not promptUser Then
* * With outRng
* * * * nData = .Cells(1, 1)
* * * * nSelect = .Cells(2, 1)
* * * * maxMatch = .Cells(3, 1)
* * End With
#Else
* * Dim chkNum As Long
* * With Sheets("input")
* * * * Set inRng = _
* * * * * *.Range("a1", .Range("a1").End(xlDown))
* * End With
* * chkNum = inRng.Count

* * nData = InputBox("Enter size of data set", _
* * * * "", chkNum)
* * If nData <= 0 Or nData chkNum _
* * * *Then GoTo terminate

* * nSelect = _
* * * * InputBox("Enter size of combination", _
* * * * "", nData)
* * If nSelect <= 0 Or nSelect nData _
* * * * Then GoTo terminate

* * maxMatch = _
* * * * InputBox("Enter max number of matches", _
* * * * "", nSelect)
* * If maxMatch <= 0 Or maxMatch nSelect _
* * * * Then GoTo terminate
#End If

st0 = Timer

maxCombin = WorksheetFunction.Combin(nData, nSelect)
maxSubset = _
* * Range("a1").SpecialCells(xlLastCell).End(xlDown).R ow _
* * - outRng.Row + 1
If maxSubset maxCombin Then maxSubset = maxCombin
If maxSubset limSubset Then maxSubset = limSubset

' clear one more column in case nSelect for previous
' run was larger. *do not clear column 1
outRng.Offset(0, 1).Resize(maxSubset, nSelect + 1).Clear

#If dataIsLong Then
* * ReDim allcombin(1 To 1, 1 To nSelect) As Long
* * ReDim mySubset(1 To maxSubset, 1 To nSelect) As Long
* * ReDim myData(1 To nData) As Long
#Else
* * ReDim allcombin(1 To 1, 1 To nSelect)
* * ReDim mySubset(1 To maxSubset, 1 To nSelect)
* * ReDim myData(1 To nData)
#End If

#If Not promptUser Then
* * For i = 1 To nData: myData(i) = i: Next
#Else
* * For i = 1 To nData: myData(i) = inRng(i): Next
#End If

ReDim idx(1 To nSelect) As Long
For i = 1 To nSelect: idx(i) = i: Next

nCombin = 0: nSubset = 0: nMatch = 0: st = 0
i = 1
Do
* * ' generate next combination

* * nCombin = nCombin + 1
* * For i = i To nSelect
* * * * allcombin(1, i) = myData(idx(i))
* * Next

* * ' be sure it matches maxMatch or less.
* * ' if so, add to mySubset

* * For i = 1 To nSubset
* * * * nMatch = 0
* * * * For j = 1 To nSelect
* * * * * * x = allcombin(1, j)
* * * * * * For k = 1 To nSelect
* * * * * * * * If x = mySubset(i, k) _
* * * * * * * * * * Then nMatch = nMatch + 1: Exit For
* * * * * * Next
* * * * Next
* * * * If nMatch maxMatch Then Exit For
* * Next
* * If nMatch <= maxMatch Then
* * * * nSubset = nSubset + 1
* * * * For j = 1 To nSelect
* * * * * * mySubset(nSubset, j) = allcombin(1, j)
* * * * Next
* * * * If nSubset = maxSubset Then GoTo showResults
* * End If
* * If nCombin = maxCombin Then GoTo showResults

* * ' update status every 1 sec

* * If Timer - st = 1 Then
* * * * st = Timer
* * * * Application.StatusBar = _
* * * * * * Round(nCombin / maxCombin * 100) & _
* * * * * * "%, " & Round(st - st0) & _
* * * * * * " sec, " & nCombin & " of " & _
* * * * * * maxCombin & ", " & nSubset
* * * * DoEvents
* * End If

* * ' next combination index

* * i = nSelect: j = 0
* * While idx(i) = nData - j
* * * * i = i - 1: j = j + 1
* * Wend
* * idx(i) = idx(i) + 1
* * For j = i + 1 To nSelect
* * * * idx(j) = idx(j - 1) + 1
* * Next
Loop

showResults:

Application.ScreenUpdating = False
With outRng
* * #If promptUser Then
* * * * .Cells(1, 1) = nData
* * * * .Cells(2, 1) = nSelect
* * * * .Cells(3, 1) = maxMatch
* * #End If
* * .Cells(4, 1) = nCombin
* * .Cells(5, 1) = nSubset
* * .Cells(1, 2).Resize(nSubset, nSelect) = mySubset
* * .Cells(6, 1) = Format(Timer - st0, "0.000")
End With

terminate:

Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub

I posted a message thanking you for your help but i dont see it
showing up here. I however have had a chance to try the code doulbling
the values but I appears to be using up too much memory and gets
sluggish or even stops altogether. Can you try writitng the output to
the worksheet as it is processed. I think that way It will use less
memory.
Derick