Output combinations from specified criteria.

[S.H.A.D.O.]

Good morning,

I have really been trying to write some VBA code for weeks now but to no avail.
I basically want to output combinations [6 numbers in each combination] based on certain criteria.
So if I ONLY wanted to output combinations with 3 LOW numbers, 3 HIGH numbers, 3 ODD numbers, and 3 EVEN numbers using CASE statements, how would I do that please?
Here is some code [I have just used 12 numbers for my test but it will actually be more] I have been working on but I can't get even close to it outputting correctly [it outputs ALL the combinations!] . . .

Option Explicit
Option Base 1

Const MinA As Integer = 1
Const MaxF As Integer = 12

Sub Selection()
    Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer
    Dim IsWhatever As Long
    Dim n(1 To 12) As Long        ' IsWhatever ? (No = 0, Yes = 1).
    Dim nWhatever(0 To 6) As Long ' Hold IsWhatever count.
    Dim Total As Long
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    Cells(1, 1).Select
  
    For IsWhatever = 1 To UBound(n)
        Select Case IsWhatever
            Case 1, 2, 3, 4, 5, 6
                n(IsWhatever) = 1
            Case 7, 8, 9, 10, 11, 12
                n(IsWhatever) = 1
            Case 1, 3, 3, 7, 9, 11
                n(IsWhatever) = 1
            Case 2, 4, 6, 8, 10, 12
                n(IsWhatever) = 1
            Case Else
                n(IsWhatever) = 0
        End Select
    Next IsWhatever
  
    For A = MinA To MaxF - 5
        For B = A + 1 To MaxF - 4
            For C = B + 1 To MaxF - 3
                For D = C + 1 To MaxF - 2
                    For E = D + 1 To MaxF - 1
                        For F = E + 1 To MaxF
                            With Application.WorksheetFunction
                                ActiveCell.Value = .Text(A, "00") & "-" _
                                    & .Text(B, "00") & "-" _
                                    & .Text(C, "00") & "-" _
                                    & .Text(D, "00") & "-" _
                                    & .Text(E, "00") & "-" _
                                    & .Text(F, "00")
                                ActiveCell.Offset(1, 0).Select
                            End With
                        Next F
                    Next E
                Next D
            Next C
        Next B
    Next A
  
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

Now the structure of this is 3333 [3 LOW, 3 HIGH, 3 ODD, 3 EVEN].

So what I would like is . . .

[1] An input box where I could input the 3333, or 1560, or 4224, or whatever distribution and it will output the combinations accordingly please.
[2] Output the combinations in individual cells rather than one cell separated with a "-".

Thanks in advance.

 

[S.H.A.D.O.]

I have got a bit further to resolving this.
I found some code [and I heavily adapted it] that asks how many LOW and how many ODD you want in each combination.
This gets round the question of how I can get that information into the code.
Now it actually works for the ODD and EVEN but not for LOW and HIGH.

[1] How can I get it to also include the LOW and HIGH as well?
[2] Get it to just output to the Active Sheet please.

Here is the code . . .

Option Explicit

Sub Generate()

Const MainSheet As String = "Sheet1"
Const SheetPrefix As String = "Part"
Dim SplitPoint As Long '= 65000
SplitPoint = ActiveSheet.Rows.Count
Const HighBall As Integer = 12

Dim sFileName As String
Dim SheetNumber As Integer
Dim iRow As Long
Dim iRec As Long
Dim iLastRow As Long
Dim ws As Worksheet
Dim sTime As Date
Dim OEMessage As String
Dim HLMessage As String
Dim Odd As Long
Dim Low As Long

Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim p4 As Integer
Dim p5 As Integer
Dim p6 As Integer

Sheets(MainSheet).Columns("A:F").ClearContents

OEMessage = vbCrLf & "How many Odd?"
Odd = CLng(InputBox(OEMessage))
If MsgBox("Proceed to create " & Odd & " Odd and " & (6 - Odd) & " Even combinations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

HLMessage = vbCrLf & "How many Low?"
Low = CLng(InputBox(HLMessage))
If MsgBox("Proceed to create " & Low & " Low and " & (6 - Low) & " High combinations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

sTime = Now()
SheetNumber = 0
iRow = SplitPoint
iRec = 0

For p1 = 1 To HighBall - 5
  For p2 = p1 + 1 To HighBall - 4
    For p3 = p2 + 1 To HighBall - 3
      For p4 = p3 + 1 To HighBall - 2
        For p5 = p4 + 1 To HighBall - 1
          For p6 = p5 + 1 To HighBall
            If IIf((p1 Mod 2), 1, 0) + IIf((p2 Mod 2), 1, 0) + IIf((p3 Mod 2), 1, 0) + IIf((p4 Mod 2), 1, 0) + IIf((p5 Mod 2), 1, 0) + IIf((p6 Mod 2), 1, 0) = Odd Then
              iRec = iRec + 1
              iRow = iRow + 1
              If iRow > SplitPoint Then
                If SheetNumber > 0 Then
                  iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
                  Sheets(MainSheet).Cells(iLastRow, 2) = iRow - 1
                End If
                SheetNumber = SheetNumber + 1
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = SheetPrefix & Right("00" & CStr(SheetNumber), 3)
                Sheets(MainSheet).Activate
                iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
                Set ws = Sheets(SheetPrefix & Right("00" & CStr(SheetNumber), 3))
                Sheets(MainSheet).Cells(iLastRow + 1, 1) = ws.Name
                iRow = 1
              End If
              ws.Cells(iRow, 1) = p1
              ws.Cells(iRow, 2) = p2
              ws.Cells(iRow, 3) = p3
              ws.Cells(iRow, 4) = p4
              ws.Cells(iRow, 5) = p5
              ws.Cells(iRow, 6) = p6
            End If
            DoEvents
          Next p6
        Next p5
      Next p4
    Next p3
  Next p2
Next p1
 
MsgBox vbCrLf & Format(iRec, "#,###") & " records created" & Space(10) & vbCrLf & vbCrLf _
   & "Run time: " & Format(Now() - sTime, "hh:nn:ss"), vbOKOnly + vbInformation
End Sub

 

[S.H.A.D.O.]

I have got a little further with respect to the LOW numbers. However, it is still only producing combinations with the ODD criteria!

Option Explicit

Sub Generate()

Const MainSheet As String = "Sheet1"
Const SheetPrefix As String = "Part"
Dim SplitPoint As Long '= 65000
SplitPoint = ActiveSheet.Rows.Count
Const HighBall As Integer = 12

Dim sFileName As String
Dim SheetNumber As Integer
Dim iRow As Long
Dim iRec As Long
Dim iLastRow As Long
Dim ws As Worksheet
Dim sTime As Date
Dim OEMessage As String
Dim HLMessage As String
Dim Odd As Long
Dim Low As Long
Dim nLow As Integer

Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim p4 As Integer
Dim p5 As Integer
Dim p6 As Integer

nLow = 8

Sheets(MainSheet).Columns("A:F").ClearContents

OEMessage = vbCrLf & "How many Odd?"
Odd = CLng(InputBox(OEMessage))
If MsgBox("Proceed to create " & Odd & " Odd and " & (6 - Odd) & " Even combinations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

HLMessage = vbCrLf & "How many Low?"
Low = CLng(InputBox(HLMessage))
If MsgBox("Proceed to create " & Low & " Low and " & (6 - Low) & " High combinations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

sTime = Now()
SheetNumber = 0
iRow = SplitPoint
iRec = 0

For p1 = 1 To HighBall - 5
  For p2 = p1 + 1 To HighBall - 4
    For p3 = p2 + 1 To HighBall - 3
      For p4 = p3 + 1 To HighBall - 2
        For p5 = p4 + 1 To HighBall - 1
          For p6 = p5 + 1 To HighBall
            If IIf((p1 Mod 2), 1, 0) + IIf((p2 Mod 2), 1, 0) + IIf((p3 Mod 2), 1, 0) + IIf((p4 Mod 2), 1, 0) + IIf((p5 Mod 2), 1, 0) + IIf((p6 Mod 2), 1, 0) = Odd Then
            If (p1 <= nLow) + (p2 <= nLow) + (p3 <= nLow) + (p4 <= nLow) + (p5 <= nLow) + (p6 <= nLow) = Low Then
              iRec = iRec + 1
              iRow = iRow + 1
              If iRow > SplitPoint Then
                If SheetNumber > 0 Then
                  iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
                  Sheets(MainSheet).Cells(iLastRow, 2) = iRow - 1
                End If
                SheetNumber = SheetNumber + 1
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = SheetPrefix & Right("00" & CStr(SheetNumber), 3)
                Sheets(MainSheet).Activate
                iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
                Set ws = Sheets(SheetPrefix & Right("00" & CStr(SheetNumber), 3))
                Sheets(MainSheet).Cells(iLastRow + 1, 1) = ws.Name
                iRow = 1
              End If
              ws.Cells(iRow, 1) = p1
              ws.Cells(iRow, 2) = p2
              ws.Cells(iRow, 3) = p3
              ws.Cells(iRow, 4) = p4
              ws.Cells(iRow, 5) = p5
              ws.Cells(iRow, 6) = p6
            End If
            End If
            DoEvents
          Next p6
        Next p5
      Next p4
    Next p3
  Next p2
Next p1
 
MsgBox vbCrLf & Format(iRec, "#,###") & " records created" & Space(10) & vbCrLf & vbCrLf _
   & "Run time: " & Format(Now() - sTime, "hh:nn:ss"), vbOKOnly + vbInformation
End Sub

Thanks in advance.

 

[S.H.A.D.O.]

Not to worry, I have managed to sort it out,