delete each combination without specific numbers

[excelNewbie22]

hi,
i saw this macro in Excel List All Lottery Combinations - 2441
of johnnyL
and modified it with his help
can someone help me with 2 macro's for:
deleting any set of numbers without 1 or 2 or 3 numbers from predefined range (like 1-2-3-4-5-6)?
and another for:
deleting any set of numbers which all even or all odd ? (if possible separate macro of the odd and separate for the even)

Sub List6of37ViaArray()
'
    Dim ArraySlotCount                  As Long
    Dim Ball_1                          As Long, Ball_2 As Long, Ball_3 As Long, Ball_4 As Long, Ball_5 As Long, Ball_6 As Long
    Dim ColumnIncrement                 As Long
    Dim CombinationCounter              As Long
    Dim ThisRow                         As Long
    Dim MaxWhiteBallValue               As Long
    Dim TotalExpectedCominations        As Long
    Dim ThisColumn                      As Long
'
    Const MaxRows As Long = 1000000                                                                           ' Set to maximum number of slots in Array
    Const BallsToDraw As Long = 6                                                                           ' <--- Set the number of balls to be drawn
    MaxWhiteBallValue = 37                                                                                  ' <--- Set to highest value of white ball
'
    Dim CombinationsArray(1 To MaxRows, 1 To BallsToDraw)   As Variant                                      ' Set Length and Width of array
'
    ArraySlotCount = 0                                                                                      ' Initialize ArraySlotCount
    ColumnIncrement = BallsToDraw + 1                                                                       ' Set the number of columns to advance
    CombinationCounter = 1                                                                                  ' Initialize CombinationCounter
    ThisColumn = 1                                                                                          ' Initialize 1st column to display results in
    ThisRow = 0                                                                                             ' Initialize row counter
    TotalExpectedCominations = Application.Combin(MaxWhiteBallValue, BallsToDraw)                           ' Expected # of total combinations
'
    Application.ScreenUpdating = False                                                                      ' Turn Screen Updating off
'
    For Ball_1 = 1 To MaxWhiteBallValue - 5                                                                 ' Establish loop for 1st ball
        For Ball_2 = (Ball_1 + 1) To MaxWhiteBallValue - 4                                                  '   Establish loop for 2nd ball
            For Ball_3 = (Ball_2 + 1) To MaxWhiteBallValue - 3                                              '       Establish loop for 3rd ball
                For Ball_4 = (Ball_3 + 1) To MaxWhiteBallValue - 2                                          '           Establish loop for 4th ball
                    For Ball_5 = (Ball_4 + 1) To MaxWhiteBallValue - 1                                         '               Establish loop for 5th ball
                       For Ball_6 = (Ball_5 + 1) To MaxWhiteBallValue                                              '               Establish loop for 6th ball
                            ArraySlotCount = ArraySlotCount + 1                                             '                       Increment ArraySlotCount
'
'                           Save combination into array
                            CombinationsArray(ArraySlotCount, 1) = Ball_1                                   '                       Save ball number to array
                            CombinationsArray(ArraySlotCount, 2) = Ball_2                                   '                       Save ball number to array
                            CombinationsArray(ArraySlotCount, 3) = Ball_3                                   '                       Save ball number to array
                            CombinationsArray(ArraySlotCount, 4) = Ball_4                                   '                       Save ball number to array
                            CombinationsArray(ArraySlotCount, 5) = Ball_5                                   '                       Save ball number to array
                            CombinationsArray(ArraySlotCount, 6) = Ball_6                                   '                       Save ball number to array
'
                            CombinationCounter = CombinationCounter + 1                                     '                       Increment CombinationCounter
'
                            If CombinationCounter Mod 550000 = 0 Then                                       '                       If CombinationCounter = 550k then ...
'                               Update StatusBar about every 10 seconds
                                Application.StatusBar = "Result " & CombinationCounter & " on way to " & TotalExpectedCominations
'
                                DoEvents                                                                    '                           DoEvents
                            End If
'
                            ThisRow = ThisRow + 1                                                           '                       Increment row counter
'
                            If ThisRow = MaxRows Then                                                       '                       If row count=array max slots
'                               Dump contents of CombinationsArray to the screen
                                Range(Cells(1, ThisColumn), Cells(ThisRow, ThisColumn + BallsToDraw - 1)) = CombinationsArray
'
                                Erase CombinationsArray                                                     '                           Erase contents of array
                                ArraySlotCount = 0                                                          '                           Reset ArraySlotCount
                                ThisRow = 0                                                                 '                           Reset row counter
                                ThisColumn = ThisColumn + ColumnIncrement                                   '                           Increment column counter
                            End If
                    Next
                Next
            Next
        Next
    Next
Next
'
    Range(Cells(1, ThisColumn), Cells(ThisRow, ThisColumn + BallsToDraw - 1)) = CombinationsArray           ' Dump contents of last array to the screen
    Columns.AutoFit                                                                                         ' Resize all columns to fit the data within them
    Application.StatusBar = "Completed!"                                                                    ' Let user know via status bar that program is done
'
    Application.ScreenUpdating = True                                                                       ' Turn Screen Updating back on
End Sub

 

[excelNewbie22]

many seconds indeed,
worked like you said,
the only problem is how to remove odds and evens only without deleting the existing rows?

 

[Anthony47]

the only problem is how to remove odds and evens only without deleting the existing rows?

I don't understand what you mean, and probably that mean that I never understood what you asked for...

 

[excelNewbie22]

i meant, each time i run the macro with different variables - which is working perfectly!
it delete everything, and gave results,
so if i want all combinations without the "only odd" and "only even",
it isn't possible with the current macro

 

[Anthony47]

i meant, each time i run the macro with different variables - which is working perfectly!
it delete everything, and gave results,
so if i want all combinations without the "only odd" and "only even",
it isn't possible with the current macro

So you would like to remove with the same macro all the combinations that have either all even numbers or all odd numbers?
If this is the request then I should suggest a variant of the Sub List6of37ViaArrayOE. With the following code we count in eArr how many balls are even; then when we are ready to save the combination we check how many of the numbers are even: since we want to bar the combinations with all evens or with all odds we save the combinations that pass the following test:

     If Application.WorksheetFunction.Sum(eArr) < 6 And Application.WorksheetFunction.Sum(eArr) > 0 Then

This condition implies that there is at least 1 even but less than 6 (thus max 5, leaving at least one odd). See note ahead.

The code:

Sub List6of37ViaArrayOE2()
'
    Dim ArraySlotCount                  As Long
    Dim Ball_1                          As Long, Ball_2 As Long, Ball_3 As Long, Ball_4 As Long, Ball_5 As Long, Ball_6 As Long
    Dim ColumnIncrement                 As Long
    Dim CombinationCounter              As Long
    Dim ThisRow                         As Long
    Dim MaxWhiteBallValue               As Long
    Dim TotalExpectedCominations        As Long
    Dim ThisColumn                      As Long
'
Dim lArray As Variant, Ball_Sum As Long
'
    Const MaxRows As Long = 1000000                                                                           ' Set to maximum number of slots in Array
    Const BallsToDraw As Long = 6                                                                           ' <--- Set the number of balls to be drawn
    MaxWhiteBallValue = 37                                                                                  ' <--- Set to highest value of white ball
'
    Dim CombinationsArray(1 To MaxRows, 1 To BallsToDraw)   As Variant                                      ' Set Length and Width of array
'
''Dim IsOE As Variant
''IsOE = True             'True=OddValues / False=EvenValues / 3=doesn't matter
Dim eArr(1 To 6)            '+++Store Even balls

Range("A:Z").ClearContents
    ArraySlotCount = 0                                                                                      ' Initialize ArraySlotCount
    ColumnIncrement = BallsToDraw + 1                                                                       ' Set the number of columns to advance
    CombinationCounter = 1                                                                                  ' Initialize CombinationCounter
    ThisColumn = 1                                                                                          ' Initialize 1st column to display results in
    ThisRow = 0                                                                                             ' Initialize row counter
    TotalExpectedCominations = Application.Combin(MaxWhiteBallValue, BallsToDraw)                           ' Expected # of total combinations
'
    Application.ScreenUpdating = False                                                                      ' Turn Screen Updating off
'
    For Ball_1 = 1 To MaxWhiteBallValue - 5                                                                 ' Establish loop for 1st ball
        If Application.WorksheetFunction.IsEven(Ball_1) = True Then eArr(1) = 1 Else eArr(1) = 0
            For Ball_2 = (Ball_1 + 1) To MaxWhiteBallValue - 4                                                  '   Establish loop for 2nd ball
                If Application.WorksheetFunction.IsEven(Ball_2) = True Then eArr(2) = 1 Else eArr(2) = 0
                    For Ball_3 = (Ball_2 + 1) To MaxWhiteBallValue - 3                                              '       Establish loop for 3rd ball
                        If Application.WorksheetFunction.IsEven(Ball_3) = True Then eArr(3) = 1 Else eArr(3) = 0
                            For Ball_4 = (Ball_3 + 1) To MaxWhiteBallValue - 2                                          '           Establish loop for 4th ball
                                If Application.WorksheetFunction.IsEven(Ball_4) = True Then eArr(4) = 1 Else eArr(4) = 0
                                    For Ball_5 = (Ball_4 + 1) To MaxWhiteBallValue - 1                                         '               Establish loop for 5th ball
                                        If Application.WorksheetFunction.IsEven(Ball_5) = True Then eArr(5) = 1 Else eArr(5) = 0
                                            For Ball_6 = (Ball_5 + 1) To MaxWhiteBallValue                                              '               Establish loop for 6th ball
                                                If Application.WorksheetFunction.IsEven(Ball_6) = True Then eArr(6) = 1 Else eArr(6) = 0
'>>>Determine if keep or not the combination:
                                                     If Application.WorksheetFunction.Sum(eArr) < 6 And Application.WorksheetFunction.Sum(eArr) > 0 Then
                                                        ArraySlotCount = ArraySlotCount + 1                                             '                       Increment ArraySlotCount
                            '
                            '                           Save combination into array
                                                        CombinationsArray(ArraySlotCount, 1) = Ball_1                                   '                       Save ball number to array
                                                        CombinationsArray(ArraySlotCount, 2) = Ball_2                                   '                       Save ball number to array
                                                        CombinationsArray(ArraySlotCount, 3) = Ball_3                                   '                       Save ball number to array
                                                        CombinationsArray(ArraySlotCount, 4) = Ball_4                                   '                       Save ball number to array
                                                        CombinationsArray(ArraySlotCount, 5) = Ball_5                                   '                       Save ball number to array
                                                        CombinationsArray(ArraySlotCount, 6) = Ball_6                                   '                       Save ball number to array
                            '
                                                        CombinationCounter = CombinationCounter + 1                                     '                       Increment CombinationCounter
                            '
                                                        If CombinationCounter Mod 50000 = 0 Then                                       '                       If CombinationCounter = 550k then ...
                            '                               Update StatusBar about every 10 seconds
                                                            Application.StatusBar = "Result " & CombinationCounter & " on way to " & TotalExpectedCominations
                                                            DoEvents                                                                    '                           DoEvents
                                                        End If
                            '
                                                        ThisRow = ThisRow + 1                                                           '                       Increment row counter
                            '
                                                        If ThisRow = MaxRows Then                                                       '                       If row count=array max slots
                            '                               Dump contents of CombinationsArray to the screen
                                                            Range(Cells(1, ThisColumn), Cells(ThisRow, ThisColumn + BallsToDraw - 1)) = CombinationsArray
                            '
                                                            Erase CombinationsArray                                                     '                           Erase contents of array
                                                            ArraySlotCount = 0                                                          '                           Reset ArraySlotCount
                                                            ThisRow = 0                                                                 '                           Reset row counter
                                                            ThisColumn = ThisColumn + ColumnIncrement                                   '                           Increment column counter
                                                        End If
                                                    End If
                                            Next Ball_6
                                    Next Ball_5
            ''                  DoEvents
                            Next Ball_4
                            DoEvents
                    Next Ball_3
            Next Ball_2
    Next Ball_1
'
    Range(Cells(1, ThisColumn), Cells(ThisRow, ThisColumn + BallsToDraw - 1)) = CombinationsArray           ' Dump contents of last array to the screen
    Columns.AutoFit                                                                                         ' Resize all columns to fit the data within them
    Application.ScreenUpdating = True                                                                       ' Turn Screen Updating back on
    DoEvents
    MsgBox "Completed!"                                 '
'
Application.StatusBar = False                           '<<<< Restore status bar
End Sub

Note: if you “play” with the “If … Then” that autorize saving the combination you might delete the all evens (If Application.WorksheetFunction.Sum(eArr) < 6 Then) or the all odds (If Application.WorksheetFunction.Sum(eArr) =0 Then), or the combinations that include any even (If Application.WorksheetFunction.Sum(eArr) =0 Then), or the combinations that include any odd (If Application.WorksheetFunction.Sum(eArr) =6 Then); and any other combination that is based on counting the evens (and thus knowing also the odds)

 

[excelNewbie22]

very good!
thanks a lot!
for the help, for the patience and for explaining !