I am in need of help to adjust the code posted below from an Excel
file. The code generate every possible combination from the value
supplied in the input boxes. Now, I do not want every combination. For
example if I want to generate the combination between 1 and 24 numbers
in subsets of 8., the first few rows of the output should look like
this:
12,3,4,5,6,7,8
1,2,3,4,9,10,11,12
1,2,3,4,13.1.4.15.16
1,2,3,4,17,18,19,20
1,2,3,4,21,22,23,24
1,2,3,5,9.13.17.21
1,2,3,5,10,14,18,22
This works on the concept that the values in each subset must not be
repeated more than four times when matched against the preceeding
subsets. This would be more easiky understood with a copy of the excel
file.
Here is the code:
Dim NFavorites As Byte 'Number of Favoritess
Dim NElements As Byte 'Number of elements in one subset
Dim maxLen As Variant
Dim SubsetCount As Variant
Dim Elements() As Integer
Dim outPut() As Integer
Dim subset As Variant
Dim NumRng As Range
Dim chkNum As Byte
Dim Favorites() As Integer
Dim rowNum As Long
Dim rngNum As Range

Sub SubSets()
Set NumRng = Sheets("The Numbers").Range("A1:A180")
Set rngNum = Sheets("Tabelle").Range("F7")
chkNum = Application.WorksheetFunction.CountA(NumRng)
On Error GoTo Terminate

NFavorites = InputBox("Please give the number of favorites",
"Selective Records", chkNum)

NElements = InputBox("Please give the number of elements of one
subset", "Selective Records", 8)
maxLen = Application.WorksheetFunction.Combin(NFavorites, NElements)
rowNum = 9
Application.StatusBar = ""
Range("A7") = maxLen
Application.EnableEvents = True
'Const Num = 1500000
ReDim Elements(1 To NElements) As Integer
ReDim Favorites(1 To NFavorites) As Integer
ReDim outPut(1, 1 To NElements) As Integer

'Fill favorites from values on worksheet
For N = 1 To NFavorites
Favorites(N) = NumRng(N)
Next N
For E = 1 To NElements
Elements(E) = E
Next E
Elements(NElements) = Elements(NElements) - 1
subset = 1
SubsetCount = subset
N = 0
mark:
Elements(NElements - N) = Elements(NElements - N) + 1
For m = NElements - N + 1 To NElements
Elements(m) = Elements(m - 1) + 1
Next m
If Elements(NElements - N) = NFavorites - N + 1 Then
If N = NElements - 1 Then
endstring = Chr(13) & Chr(13) & "The
calculation is finished."
Exit Sub
End If
N = N + 1
GoTo mark
End If
For E = 1 To NElements
outPut(subset, E) = Favorites(Elements(E))
Next E
N = 0

'Place subset on worksheet
Range(Cells(rowNum, 1),
Cells(rowNum, NElements)) = outPut()
rowNum = rowNum + 1

Range("A8").Value = rowNum - 9

cv = 0
NextMove:
maxLen = maxLen - 1
SubsetCount = SubsetCount + 1
Application.StatusBar =
Format(maxLen, "#,##0") & " Complete : " & Format(SubsetCount /
Range("A7"), "0.0000%") & " ," & outPut(1, 1) & "," & outPut(1, 2) &
"," & outPut(1, 3) & " ," & outPut(1, 4) & "," & outPut(1, 5)
r = 0
If maxLen = 0 Then
Application.EnableEvents =
True
Application.ScreenUpdating
= True
Application.Calculation =
xlCalculationAutomatic
ThisWorkbook.Save
Exit Sub
End If
cv = 0
GoTo mark
Terminate:
Exit Sub
End Sub

"Daka" wrote:
This would be more easiky understood with a copy
of the excel file.

You can upload the Excel file to a file-sharing website and post the URL
(link; http://...) in a response here. Be sure the uploaded file is marked
shared or sharable. The following are some free file-sharing websites.

Windows Live Skydrive: http://skydrive.live.com
MediaFi http://www.mediafire.com
FileFactory: http://www.filefactory.com
FileSavr: http://www.filesavr.com
FileDropper: http://www.filedropper.com
RapidSha http://www.rapidshare.com
Box.Net: http://www.box.net/files

Daka wrote:
I am in need of help to adjust the code posted
below from an Excel file. The code generate every
possible combination from the value supplied in the
input boxes. Now, I do not want every combination.
For example if I want to generate the combination
between 1 and 24 numbers in subsets of 8

This description is unclear to me, even with the example. Do you simply
want all the combinations of 8 from a set of 24 numbers, for example?

Daka wrote:
For example if I want to generate the combination
between 1 and 24 numbers in subsets of 8., the
first few rows of the output should look like this:
12,3,4,5,6,7,8
1,2,3,4,9,10,11,12
1,2,3,4,13.1.4.15.16
1,2,3,4,17,18,19,20
1,2,3,4,21,22,23,24
1,2,3,5,9.13.17.21
1,2,3,5,10,14,18,22

Does it really need to be in that order? The more natural order is:

1,2,3,4,5,6,7,8
1,2,3,4,5,6,7,9
.....
1,2,3,4,5,6,7,24
1,2,3,4,5,6,8,9
1,2,3,4,5,6,8,10
.....
1,2,3,4,5,6,8,24


Daka wrote:
This works on the concept that the values in each
subset must not be repeated more than four times
when matched against the preceeding subsets.

Huh?! In your example, 1, 2, and 3 are all "repeated more than four times"
in preceding subsets. Are you just trying to suggest an algorithm based on
ignorance of how to generate all combinations of 8 from a set of 24 numbers
(for example)?

The posted code is junk, an obvious hack of something. It did nothing
useful when I tried it.

-----

The following macro outputs all combinations of K out of N values from
Input!A:A starting in A1 as you did, writing the combinations into
Output!F:F starting in F7 as you did. I kept the variable names similar to
yours.

The macro intended to be working starting point. It might even be exactly
what you want. If not and if you cannot can make the necessary
modifications, let me know what you need (with examples), and perhaps I can
make the changes.

I suggest that you start by executing the macro as-is. Use a list of 7
numbers or strings in Input!A:A (nFavorites), and enter 3 or 4 for the size
of the subset (nElements).

That keeps the output and runtime manageable. Note that I artificially slow
down the statusbar update so that you can see that in operation. For longer
runs, set #Const slowStatus to False. Eventually, you can remove the code
between #If slowStatus and #EndIf.

***Caveat*** COMBIN(N,K) grows quite large very quickly. For example,
COMBIN(24,8) is 735,471. That exceeds the limits of XL2003. COMBIN(180,90)
is about 9E+52, which exceeds the limits of anything. So this approach is
not practical for most sets of "favorites".

-----

Option Explicit

#Const slowStatus = True

Sub combinKofN()
Dim favRng As Range, outRng As Range
Dim chkNum As Long, nFavorites As Long
Dim nElements As Long, maxLen As Long
Dim ofMaxLen As String, s As String
Dim i As Long, j As Long, rowNum As Long
Dim prevPct As Long

On Error GoTo terminate
Application.StatusBar = ""

' column A of sheet "Input" must contain
' data starting in A1, with no interstitial
' empty cells.
' output goes into column F of sheet "Output"

With Sheets("input")
Set favRng = .Range("a1", .Range("a1").End(xlDown))
End With
chkNum = favRng.Count

Set outRng = Sheets("output").Range("f7")
outRng.Resize(1, chkNum + 1).EntireColumn.Clear

' allow user to see clear output if sheet
' "output" is active
Application.ScreenUpdating = False

' generate all combinations of nElements of nFavorites

nFavorites = _
InputBox("Enter number of favorites", "", chkNum)
If nFavorites <= 0 Or nFavorites chkNum _
Then GoTo terminate

nElements = _
InputBox("Enter size of subset", "", nFavorites)
If nElements <= 0 Or nElements nFavorites _
Then GoTo terminate

maxLen = WorksheetFunction.Combin(nFavorites, nElements)
If outRng.Row + maxLen - 1 _
Range("a1").SpecialCells(xlLastCell).End(xlDown).R ow _
Then GoTo terminate
ofMaxLen = " of " & maxLen & ": " ' for status

ReDim favorites(1 To nFavorites)
For i = 1 To nFavorites: favorites(i) = favRng(i): Next

ReDim outData(1 To 1, 1 To nElements)
ReDim elements(1 To nElements) As Long
For i = 1 To nElements: elements(i) = i: Next

i = 1: rowNum = 0: prevPct = 0
Do
For i = i To nElements
outData(1, i) = favorites(elements(i))
Next
rowNum = rowNum + 1
outRng.Cells(rowNum).Resize(1, nElements) = outData
If rowNum = maxLen Then GoTo terminate

' update Excel status bar by each integer percentage

If Int(rowNum / maxLen * 100) prevPct Then
prevPct = Int(rowNum / maxLen * 100)
s = prevPct & "% complete, " & _
Format(rowNum, "#,##0") & _
ofMaxLen & outData(1, 1)
For j = 2 To nElements
s = s & "," & outData(1, j)
Next
Application.StatusBar = s
DoEvents
#If slowStatus Then
Dim x As Double
x = Timer
Do: DoEvents: Loop Until Timer - x = 0.1
#End If
End If

' next combination

i = nElements: j = 0
While elements(i) = nFavorites - j
i = i - 1: j = j + 1
Wend
elements(i) = elements(i) + 1
For j = i + 1 To nElements
elements(j) = elements(j - 1) + 1
Next
Loop

terminate:

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

Some minor comments....

"joeu2004" wrote:
outRng.Resize(1, chkNum + 1).EntireColumn.Clear

The use of chkNum+1 instead of chkNum is an aesthetic choice. If the
previous run use a large chkNum, I preferred to have one column separation
between new and old data. Of course, it would be better to clear everything
down from and to the right of outRng. But I was not sure if that might wipe
out other important data.


I wrote
rowNum = rowNum + 1
outRng.Cells(rowNum).Resize(1, nElements) = outData

This can be made more efficient. For example (untested):

Set outRng = outRng.resize(1,nElements) ' above Do loop
[....]
outRng.Offset(rowNum,0) = outData ' inside Do loop
rowNum = rowNum + 1

On Jul 3, 6:51*pm, "joeu2004" wrote:
Some minor comments....

"joeu2004" wrote:
outRng.Resize(1, chkNum + 1).EntireColumn.Clear

The use of chkNum+1 instead of chkNum is an aesthetic choice. *If the
previous run use a large chkNum, I preferred to have one column separation
between new and old data. *Of course, it would be better to clear everything
down from and to the right of outRng. *But I was not sure if that might wipe
out other important data.

I wrote

rowNum = rowNum + 1
outRng.Cells(rowNum).Resize(1, nElements) = outData

This can be made more efficient. *For example (untested):

Set outRng = outRng.resize(1,nElements) *' above Do loop
[....]
outRng.Offset(rowNum,0) = outData * * *' inside Do loop
rowNum = rowNum + 1

This is the link to the file I have and modified to do what I wanted.
https://skydrive.live.com/redir.aspx...FFE7 69AB!161

On Jul 3, 6:37*pm, "joeu2004" wrote:
"Daka" wrote:
This would be more easiky understood with a copy
of the excel file.

You can upload the Excel file to a file-sharing website and post the URL
(link; http://...) in a response here. *Be sure the uploaded file is marked
shared or sharable. *The following are some free file-sharing websites.

Windows Live Skydrive:http://skydrive.live.com
MediaFihttp://www.mediafire.com
FileFactory:http://www.filefactory.com
FileSavr:http://www.filesavr.com
FileDropper:http://www.filedropper.com
RapidShahttp://www.rapidshare.com
Box.Net:http://www.box.net/files

Daka wrote:
I am in need of help to adjust the code posted
below from an Excel file. The code generate every
possible combination from the value supplied in the
input boxes. *Now, I do not want every combination.
For example if I want to generate the combination
between 1 and 24 numbers in subsets of 8

This description is unclear to me, even with the example. *Do you simply
want all the combinations of 8 from a set of 24 numbers, for example?

Daka wrote:
For example if I want to generate the combination
between 1 and 24 numbers in subsets of 8., the
first few rows of the output should look like this:
12,3,4,5,6,7,8
1,2,3,4,9,10,11,12
1,2,3,4,13.1.4.15.16
1,2,3,4,17,18,19,20
1,2,3,4,21,22,23,24
1,2,3,5,9.13.17.21
1,2,3,5,10,14,18,22

Does it really need to be in that order? *The more natural order is:

1,2,3,4,5,6,7,8
1,2,3,4,5,6,7,9
....
1,2,3,4,5,6,7,24
1,2,3,4,5,6,8,9
1,2,3,4,5,6,8,10
....
1,2,3,4,5,6,8,24

Daka wrote:
This works on the concept that the values in each
subset must not be repeated more than four times
when matched against the preceeding subsets.

Huh?! *In your example, 1, 2, and 3 are all "repeated more than four times"
in preceding subsets. *Are you just trying to suggest an algorithm based on
ignorance of how to generate all combinations of 8 from a set of 24 numbers
(for example)?

The posted code is junk, an obvious hack of something. *It did nothing
useful when I tried it.

-----

The following macro outputs all combinations of K out of N values from
Input!A:A starting in A1 as you did, writing the combinations into
Output!F:F starting in F7 as you did. *I kept the variable names similar to
yours.

The macro intended to be working starting point. *It might even be exactly
what you want. *If not and if you cannot can make the necessary
modifications, let me know what you need (with examples), and perhaps I can
make the changes.

I suggest that you start by executing the macro as-is. *Use a list of 7
numbers or strings in Input!A:A (nFavorites), and enter 3 or 4 for the size
of the subset (nElements).

That keeps the output and runtime manageable. *Note that I artificially slow
down the statusbar update so that you can see that in operation. *For longer
runs, set #Const slowStatus to False. *Eventually, you can remove the code
between #If slowStatus and #EndIf.

***Caveat*** *COMBIN(N,K) grows quite large very quickly. *For example,
COMBIN(24,8) is 735,471. *That exceeds the limits of XL2003. *COMBIN(180,90)
is about 9E+52, which exceeds the limits of anything. *So this approach is
not practical for most sets of "favorites".

-----

Option Explicit

#Const slowStatus = True

Sub combinKofN()
Dim favRng As Range, outRng As Range
Dim chkNum As Long, nFavorites As Long
Dim nElements As Long, maxLen As Long
Dim ofMaxLen As String, s As String
Dim i As Long, j As Long, rowNum As Long
Dim prevPct As Long

On Error GoTo terminate
Application.StatusBar = ""

' column A of sheet "Input" must contain
' data starting in A1, with no interstitial
' empty cells.
' output goes into column F of sheet "Output"

With Sheets("input")
* *Set favRng = .Range("a1", .Range("a1").End(xlDown))
End With
chkNum = favRng.Count

Set outRng = Sheets("output").Range("f7")
outRng.Resize(1, chkNum + 1).EntireColumn.Clear

' allow user to see clear output if sheet
' "output" is active
Application.ScreenUpdating = False

' generate all combinations of nElements of nFavorites

nFavorites = _
* * InputBox("Enter number of favorites", "", chkNum)
If nFavorites <= 0 Or nFavorites chkNum _
* * Then GoTo terminate

nElements = _
* * InputBox("Enter size of subset", "", nFavorites)
If nElements <= 0 Or nElements nFavorites _
* * Then GoTo terminate

maxLen = WorksheetFunction.Combin(nFavorites, nElements)
If outRng.Row + maxLen - 1 _
* * Range("a1").SpecialCells(xlLastCell).End(xlDown).R ow _
* * Then GoTo terminate
ofMaxLen = " of " & maxLen & ": " *' for status

ReDim favorites(1 To nFavorites)
For i = 1 To nFavorites: favorites(i) = favRng(i): Next

ReDim outData(1 To 1, 1 To nElements)
ReDim elements(1 To nElements) As Long
For i = 1 To nElements: elements(i) = i: Next

i = 1: rowNum = 0: prevPct = 0
Do
* * For i = i To nElements
* * * * outData(1, i) = favorites(elements(i))
* * Next
* * rowNum = rowNum + 1
* * outRng.Cells(rowNum).Resize(1, nElements) = outData
* * If rowNum = maxLen Then GoTo terminate

* * ' update Excel status bar by each integer percentage

* * If Int(rowNum / maxLen * 100) prevPct Then
* * * * prevPct = Int(rowNum / maxLen * 100)
* * * * s = prevPct & "% complete, " & _
* * * * * * Format(rowNum, "#,##0") & _
* * * * * * ofMaxLen & outData(1, 1)
* * * * For j = 2 To nElements
* * * * * * s = s & "," & outData(1, j)
* * * * Next
* * * * Application.StatusBar = s
* * * * DoEvents
* * * * #If slowStatus Then
* * * * * * Dim x As Double
* * * * * * x = Timer
* * * * * * Do: DoEvents: Loop Until Timer - x = 0.1
* * * * #End If
* * End If

* * ' next combination

* * i = nElements: j = 0
* * While elements(i) = nFavorites - j
* * * * i = i - 1: j = j + 1
* * Wend
* * elements(i) = elements(i) + 1
* * For j = i + 1 To nElements
* * * * elements(j) = elements(j - 1) + 1
* * Next
Loop

terminate:

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

The code you provided worked very well. However you misunderstood what
I am trying to do. The code produces every possible combination. But i
do not want every combination.

Lets work with 24 numbers in sets of 8. We know every possible
combination would be 735,471.

I was able to achieve what I am trying to do by ajusting the code to
loop thru the subsets on the outputsheet but this was extremely slow
approach.
The first line would be:
1,2,3,4,5,6,7,8

For the second line or subset the code would compare the second subset
with whats already on the output sheet. 1,2,3,4,5, 6, 7, 9 would be
inelligible because becuse 7 of the nubers would be repeated, we only
want 4. So the next elligible subset would be 1,2,3,4,9,10,11,12 the
next would be 1,2,3,4,13,14,15,16.
As I stated before I was able to achieve this by looping thru the code
on the output sheet but it was extremely slow. It produced
approximately 759 subset.
Having the alogarithm adjusted to do this would be far more efficient
if it is possible to have it done this way.
Thanks
Derick

On 04/07/2011 01:32, Daka wrote:
On Jul 3, 6:37 pm, wrote:
wrote:
This would be more easiky understood with a copy
of the excel file.

You can upload the Excel file to a file-sharing website and post the URL
(link; http://...) in a response here. Be sure the uploaded file is marked
shared or sharable. The following are some free file-sharing websites.

Windows Live Skydrive:http://skydrive.live.com
MediaFihttp://www.mediafire.com
FileFactory:http://www.filefactory.com
FileSavr:http://www.filesavr.com
FileDropper:http://www.filedropper.com
RapidShahttp://www.rapidshare.com
Box.Net:http://www.box.net/files

Daka wrote:
I am in need of help to adjust the code posted
below from an Excel file. The code generate every
possible combination from the value supplied in the
input boxes. Now, I do not want every combination.
For example if I want to generate the combination
between 1 and 24 numbers in subsets of 8

This description is unclear to me, even with the example. Do you simply
want all the combinations of 8 from a set of 24 numbers, for example?

Daka wrote:
For example if I want to generate the combination
between 1 and 24 numbers in subsets of 8., the
first few rows of the output should look like this:
12,3,4,5,6,7,8
1,2,3,4,9,10,11,12
1,2,3,4,13.1.4.15.16
1,2,3,4,17,18,19,20
1,2,3,4,21,22,23,24
1,2,3,5,9.13.17.21
1,2,3,5,10,14,18,22

Does it really need to be in that order? The more natural order is:

1,2,3,4,5,6,7,8
1,2,3,4,5,6,7,9
....
1,2,3,4,5,6,7,24
1,2,3,4,5,6,8,9
1,2,3,4,5,6,8,10
....
1,2,3,4,5,6,8,24

Daka wrote:
This works on the concept that the values in each
subset must not be repeated more than four times
when matched against the preceeding subsets.

Huh?! In your example, 1, 2, and 3 are all "repeated more than four times"
in preceding subsets. Are you just trying to suggest an algorithm based on
ignorance of how to generate all combinations of 8 from a set of 24 numbers
(for example)?

The posted code is junk, an obvious hack of something. It did nothing
useful when I tried it.

-----

The following macro outputs all combinations of K out of N values from
Input!A:A starting in A1 as you did, writing the combinations into
Output!F:F starting in F7 as you did. I kept the variable names similar to
yours.

The macro intended to be working starting point. It might even be exactly
what you want. If not and if you cannot can make the necessary
modifications, let me know what you need (with examples), and perhaps I can
make the changes.

I suggest that you start by executing the macro as-is. Use a list of 7
numbers or strings in Input!A:A (nFavorites), and enter 3 or 4 for the size
of the subset (nElements).

That keeps the output and runtime manageable. Note that I artificially slow
down the statusbar update so that you can see that in operation. For longer
runs, set #Const slowStatus to False. Eventually, you can remove the code
between #If slowStatus and #EndIf.

***Caveat*** COMBIN(N,K) grows quite large very quickly. For example,
COMBIN(24,8) is 735,471. That exceeds the limits of XL2003. COMBIN(180,90)
is about 9E+52, which exceeds the limits of anything. So this approach is
not practical for most sets of "favorites".

-----

Option Explicit

#Const slowStatus = True

Sub combinKofN()
Dim favRng As Range, outRng As Range
Dim chkNum As Long, nFavorites As Long
Dim nElements As Long, maxLen As Long
Dim ofMaxLen As String, s As String
Dim i As Long, j As Long, rowNum As Long
Dim prevPct As Long

On Error GoTo terminate
Application.StatusBar = ""

' column A of sheet "Input" must contain
' data starting in A1, with no interstitial
' empty cells.
' output goes into column F of sheet "Output"

With Sheets("input")
Set favRng = .Range("a1", .Range("a1").End(xlDown))
End With
chkNum = favRng.Count

Set outRng = Sheets("output").Range("f7")
outRng.Resize(1, chkNum + 1).EntireColumn.Clear

' allow user to see clear output if sheet
' "output" is active
Application.ScreenUpdating = False

' generate all combinations of nElements of nFavorites

nFavorites = _
InputBox("Enter number of favorites", "", chkNum)
If nFavorites<= 0 Or nFavorites chkNum _
Then GoTo terminate

nElements = _
InputBox("Enter size of subset", "", nFavorites)
If nElements<= 0 Or nElements nFavorites _
Then GoTo terminate

maxLen = WorksheetFunction.Combin(nFavorites, nElements)
If outRng.Row + maxLen - 1 _
Range("a1").SpecialCells(xlLastCell).End(xlDown).R ow _
Then GoTo terminate
ofMaxLen = " of "& maxLen& ": " ' for status

ReDim favorites(1 To nFavorites)
For i = 1 To nFavorites: favorites(i) = favRng(i): Next

ReDim outData(1 To 1, 1 To nElements)
ReDim elements(1 To nElements) As Long
For i = 1 To nElements: elements(i) = i: Next

i = 1: rowNum = 0: prevPct = 0
Do
For i = i To nElements
outData(1, i) = favorites(elements(i))
Next
rowNum = rowNum + 1
outRng.Cells(rowNum).Resize(1, nElements) = outData
If rowNum = maxLen Then GoTo terminate

' update Excel status bar by each integer percentage

If Int(rowNum / maxLen * 100) prevPct Then
prevPct = Int(rowNum / maxLen * 100)
s = prevPct& "% complete, "& _
Format(rowNum, "#,##0")& _
ofMaxLen& outData(1, 1)
For j = 2 To nElements
s = s& ","& outData(1, j)
Next
Application.StatusBar = s
DoEvents
#If slowStatus Then
Dim x As Double
x = Timer
Do: DoEvents: Loop Until Timer - x= 0.1
#End If
End If

' next combination

i = nElements: j = 0
While elements(i) = nFavorites - j
i = i - 1: j = j + 1
Wend
elements(i) = elements(i) + 1
For j = i + 1 To nElements
elements(j) = elements(j - 1) + 1
Next
Loop

terminate:

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

The code you provided worked very well. However you misunderstood what
I am trying to do. The code produces every possible combination. But i
do not want every combination.

Lets work with 24 numbers in sets of 8. We know every possible
combination would be 735,471.

I was able to achieve what I am trying to do by ajusting the code to
loop thru the subsets on the outputsheet but this was extremely slow
approach.
The first line would be:
1,2,3,4,5,6,7,8

For the second line or subset the code would compare the second subset
with whats already on the output sheet. 1,2,3,4,5, 6, 7, 9 would be
inelligible because becuse 7 of the nubers would be repeated, we only
want 4. So the next elligible subset would be 1,2,3,4,9,10,11,12 the
next would be 1,2,3,4,13,14,15,16.

I can't see why on earth you would want to do this, but once you have a
root with the first four values determined the only possible solutions
are of the form:

1,2,3,4,5,6,7,8
1,2,3,4,5+4n,6+4n,7+4n, 8+4n

Then moving to 5 on digit 4
1,2,3,5,6+4n+p,9+4n+p, 12+4n+p, 15+4n+p

*BUT* some of these will now have more than four values in common with
the earlier patterns. The closed forms will allow you to short circuit
generating the patterns that cannot possibly match your constraint.

As I stated before I was able to achieve this by looping thru the code
on the output sheet but it was extremely slow. It produced
approximately 759 subset.
Having the alogarithm adjusted to do this would be far more efficient
if it is possible to have it done this way.
Thanks
Derick

It might help if you explained why you want to do this. It seems to me
like there is no real merit at all in this weird subset. Unless that is
you are trying to beat some very badly designed national lottery. See
for example the famous Irish Lottery syndicate which hammered them on a
double rollover by buying up almost all possible permutations.

http://en.wikipedia.org/wiki/Lottery_Wheeling

Regards,
Martin Brown

"Daka" wrote:
Lets work with 24 numbers in sets of 8. We know every
possible combination would be 735,471.
[....]
The first line would be: 1,2,3,4,5,6,7,8
For the second line or subset the code would compare
the second subset with whats already on the output
sheet. 1,2,3,4,5, 6, 7, 9 would be inelligible because
7 of the nubers would be repeated, we only want 4.
So the next elligible subset would be 1,2,3,4,9,10,11,12

Okay, I believe I understand your requirement now. For example, you want to
select combinations of 8 from a set of 24, but only the subset of
combinations with 4 or fewer matches.

(Note that I am using "subset" differently than you do. You use "subset"
where I would use the term "combination".)

Daka wrote:
I was able to achieve this by looping thru the code
on the output sheet but it was extremely slow. It
produced approximately 759 subset.

Actually, 759 is exactly the correct number for 24 choose 8 with 4 or fewer
matches.

The ideal algorithm would generate the 759 combinations directly, without
having to generate all 735,471 combinations. But I am having trouble
"counting" (i.e. computing the count of) the number of the subset of
combinations that fit the requirement. And for me, knowing how to "count"
is key to understanding the simplest algorithm.

The macro below is a brute force approach. It consumes a significant amount
of memory. But it should run significantly faster than processing all of
the combinations stored in a worksheet, if that is what you mean by "looping
thru the code on the output sheet". For example, on my computer, the
algorithm takes about 77 sec to produce the 759 combinations that meet the
requirements of your example.

***CAVEAT*** That is based on the assumption that the set of 24 data are
type Long. If the data might be something else, set the #Const is
dataIsLong to False. But in that case, certain variables are type Variant,
and the algorithm run significantly longer; for example, about 120 sec to
produce the 759 combinations.

Is that the sort of algorithm you were hoping for?

PS: I was unable to open or download the Excel file that you uploaded to
Skydrive. That is, I refused to open it. I got a download block message
indicating that the file had some "suspicious" requirements; a DLL.
Probably innocuous; but I did not want to take any chances. I wonder if the
file is simply incompatible with my XL2003/WinXP system.

------

Option Explicit

' set to False if Input!A:A is not integer
#Const dataIsLong = True

Sub combinKofN()
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 chkNum 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

With Sheets("input")
Set inRng = _
.Range("a1", .Range("a1").End(xlDown))
End With
chkNum = inRng.Count

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

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

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

' clear one more column in case nSelect for previous
' run was larger
outRng.Resize(maxSubset, nSelect + 2).Clear

#If dataIsLong Then
ReDim allCombin(1 To maxCombin, 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 maxCombin, 1 To nSelect)
ReDim mySubset(1 To maxSubset, 1 To nSelect)
ReDim myData(1 To nData)
#End If
For i = 1 To nData: myData(i) = inRng(i): Next

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

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

nCombin = nCombin + 1
For i = 1 To nSelect
allCombin(nCombin, 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(nCombin, 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(nCombin, j)
Next
End If

' 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
If nSubset = maxSubset Then GoTo showResults
If nCombin = maxCombin Then GoTo showResults

' 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
.Cells(1, 1) = nData
.Cells(2, 1) = nSelect
.Cells(3, 1) = maxMatch
.Cells(4, 1) = nCombin
.Cells(5, 1) = nSubset
.Cells(1, 2).Resize(nSubset, nSelect) = mySubset
End With

terminate:

Application.StatusBar = ""
Application.ScreenUpdating = True
outRng.Cells(6, 1) = Format(Timer - st0, "0.000")
End Sub

Errata....

"joeu2004" wrote:
.Cells(1, 2).Resize(nSubset, nSelect) = mySubset
End With

terminate:

Application.StatusBar = ""
Application.ScreenUpdating = True
outRng.Cells(6, 1) = Format(Timer - st0, "0.000")

More reliable....


.Cells(1, 2).Resize(nSubset, nSelect) = mySubset
.Cells(6, 1) = Format(Timer - st0, "0.000")
End With

terminate:

Application.StatusBar = ""
Application.ScreenUpdating = True

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

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