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