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

 

[Anthony47]

As far as the odd/even selection, I suggest adding a test after each new Ball_x is drawn against a new variable (IsOE).
I have modified your code to insert this test on Ball_1 and Ball_2; extend this concept to the remaining Ball_x

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
'
Dim IsOE As Variant                                                                  '<<<<
IsOE = False             'True=OddValues / False=EvenValues / 0=doesn't matter       '<<<<

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) <> IsOE Then                 '<<<<
            For Ball_2 = (Ball_1 + 1) To MaxWhiteBallValue - 4                                                  '   Establish loop for 2nd ball
                If Application.WorksheetFunction.IsEven(Ball_2) <> IsOE Then         '<<<<
                    For Ball_3 = (Ball_2 + 1) To MaxWhiteBallValue - 3                                              '       Establish loop for 3rd ball

'etc
'etc
'etc

                    Next Ball_3
                End If
            Next Ball_2
        End If
    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
    DoEvents
    MsgBox "Completed!"                                 '<<<< Modified
'
    Application.ScreenUpdating = True                                                                       ' Turn Screen Updating back on
Application.StatusBar = False                           '<<<< Restore status bar
End Sub

You will notice also that I clear the sheet before starting the process, use a msgbox to report the complexion, and restore the status bar before ending the macro


As far as checking the presence of numbers in a list, I suggest that you create an array of the list:

Dim lArray As Variant, Ball_Sum As Long

lArray = Array(1, 2, 3, 4)           '<<<< Your list

Then, before saving into the CombinationArray, you count how many of your balls are in the list and decide:

                                          For Ball_6 = (Ball_5 + 1) To MaxWhiteBallValue  
                                             If Application.WorksheetFunction.IsEven(Ball_6) <> IsOE Then         '<<<<
                                             'Added test:                                                         '<<<<
                                       Ball_Sum = 0
                                                If Not IsError(Application.Match(Ball_1, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                                                If Not IsError(Application.Match(Ball_2, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                                                '                                                
                                                'etc for the remaining 4 Ball_xx
                                                '
                                                If Ball_Sum > 3 then                   '<<< YOUR threshold, end of test
'>>>> Your current inner block of code
                                                   ArraySlotCount = ArraySlotCount + 1                                             '                       Increment ArraySlotCount
                      
                       '                           Save combination into array
                                                   CombinationsArray(ArraySlotCount, 1) = Ball_1                                   '                       Save ball number to array                                                   
                                                     'etc
                                                     'etc
                                                     'etc
                                                     'etc
                                                       ThisColumn = ThisColumn + ColumnIncrement                                   '                           Increment column counter
                                                   End If

                                                 End If                                 '<<< Added If /Endif
                                             Next Ball_6
                                          'etc
                                          'etc
                                          'etc

 

[excelNewbie22]

first macro returns an error at line
"Range(Cells(1, ThisColumn), Cells(ThisRow, ThisColumn + BallsToDraw - 1)) = CombinationsArray ' Dump contents of last array to the screen"

"I have modified your code" - not my code, johnnyL's

don't know what it means
"....Ball_1 and Ball_2; extend this concept to the remaining Ball_x"

 

[Anthony47]

don't know what it means
"....Ball_1 and Ball_2; extend this concept to the remaining Ball_x"

I mean that I showed which modifications are to be done. You want to test 6 "balls" against some contrains; I showed how apply the modifications to the first 2 balls, it should not be difficuult to replay the modification to the remaining 4 "balls": you have to insert in the coirrect position 4 If .. Then /End If

Indeed I modified the first 4 balls against the Odd /Even test; the full code of the macro is:

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
'
Dim lArray As Variant, Ball_Sum As Long

lArray = Array(1, 2, 3, 4)
Ball_Sum = 0
If Not IsError(Application.Match(Ball_1, lArray, False)) Then Ball_Sum = Ball_Sum + 1
If Not IsError(Application.Match(Ball_2, lArray, False)) Then Ball_Sum = Ball_Sum + 1
'etc for the remaining 4 Ball_xx
    
    
    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 = False             'True=OddValues / False=EvenValues / 0=doesn't matter

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) <> IsOE Then
            For Ball_2 = (Ball_1 + 1) To MaxWhiteBallValue - 4                                                  '   Establish loop for 2nd ball
                If Application.WorksheetFunction.IsEven(Ball_2) <> IsOE Then
                    For Ball_3 = (Ball_2 + 1) To MaxWhiteBallValue - 3                                              '       Establish loop for 3rd ball
                        If Application.WorksheetFunction.IsEven(Ball_3) <> IsOE Then
                            For Ball_4 = (Ball_3 + 1) To MaxWhiteBallValue - 2                                          '           Establish loop for 4th ball
                                If Application.WorksheetFunction.IsEven(Ball_4) <> IsOE Then
                                    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 Ball_6
                                    Next Ball_5
                                End If
            ''                  DoEvents
                            Next Ball_4
                            DoEvents
                        End If
                    Next Ball_3
                End If
            Next Ball_2
        End If
    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
    DoEvents
    MsgBox "Completed!"                                 '<<<< Modified
'
    Application.ScreenUpdating = True                                                                       ' Turn Screen Updating back on
Application.StatusBar = False                           '<<<< Restore status bar
End Sub

What I get:

2 4 6 8 9 10
2 4 6 8 9 11
2 4 6 8 9 12
2 4 6 8 9 13
2 4 6 8 9 14
2 4 6 8 9 15
etc 
etc

So you have to insert only 2 additional If..Then /End If to complete the job

 

[montecarlo2012]

Hi. I believe that maybe would be easy if you pick some numbers and create a drop-down list only with certain numbers and add some conditions.
like how many odds and even per combination
sum range on every combination etc. etc.

 

[excelNewbie22]

Anthony47
i appreciate your help, but forgive my ignorance,
can you please simplify things for me?

i need the macro's separate
one for ruling out odds only
one for ruling out evens only
and one for ruling out any combination without at least one or 2 or 3 (no 4, 5,6) of the array of numbers, like 1-2-3-4-5-6 or more....

if you already done it, again, sorry... i don't understand what to change

 

[excelNewbie22]

tried some more, and
did you meant this part?

lArray = Array(1, 2, 3, 4, 5, 6)
Ball_Sum = 0
If Not IsError(Application.Match(Ball_1, lArray, False)) Then Ball_Sum = Ball_Sum + 1
If Not IsError(Application.Match(Ball_2, lArray, False)) Then Ball_Sum = Ball_Sum + 1
If Not IsError(Application.Match(Ball_3, lArray, False)) Then Ball_Sum = Ball_Sum + 1
If Not IsError(Application.Match(Ball_4, lArray, False)) Then Ball_Sum = Ball_Sum + 1
If Not IsError(Application.Match(Ball_5, lArray, False)) Then Ball_Sum = Ball_Sum + 1
If Not IsError(Application.Match(Ball_6, lArray, False)) Then Ball_Sum = Ball_Sum + 1
'etc for the remaining 4 Ball_xx

tried to run it like this, it returned only approx 100000 results
with the 'switch' of

IsOE = False             'True=OddValues / False=EvenValues / 0=doesn't matter

and still don't make sense,
a- it is too few results out of 2,3 mill
b- there's always at least four even (where the rest like 1-2-8-11-13)
c- there's results, without at least one number from 123456

 

[Anthony47]

can you please simplify things for me?

I try teaching you the recipe, cooking some of the food and expecting to to complete the cooking, but I see you need a complete service, that is beyond the objective of a forum…
Anyway, I cooked 4 “balls”, it’s not difficult for me (but shouldn’t had been difficult for you too) to cook also the remaining 2 balls.
The macro that extract only Odd, or Even or all genre balls is this:

Sub List6of37ViaArrayOE()
'
    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

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) <> IsOE Then
            For Ball_2 = (Ball_1 + 1) To MaxWhiteBallValue - 4                                                  '   Establish loop for 2nd ball
                If Application.WorksheetFunction.IsEven(Ball_2) <> IsOE Then
                    For Ball_3 = (Ball_2 + 1) To MaxWhiteBallValue - 3                                              '       Establish loop for 3rd ball
                        If Application.WorksheetFunction.IsEven(Ball_3) <> IsOE Then
                            For Ball_4 = (Ball_3 + 1) To MaxWhiteBallValue - 2                                          '           Establish loop for 4th ball
                                If Application.WorksheetFunction.IsEven(Ball_4) <> IsOE Then
                                    For Ball_5 = (Ball_4 + 1) To MaxWhiteBallValue - 1                                         '               Establish loop for 5th ball
                                        If Application.WorksheetFunction.IsEven(Ball_5) <> IsOE Then
                                            For Ball_6 = (Ball_5 + 1) To MaxWhiteBallValue                                              '               Establish loop for 6th ball
                                                If Application.WorksheetFunction.IsEven(Ball_6) <> IsOE 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 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
                                                End If
                                            Next Ball_6
                                        End If
                                    Next Ball_5
                                End If
            ''                  DoEvents
                            Next Ball_4
                            DoEvents
                        End If
                    Next Ball_3
                End If
            Next Ball_2
        End If
    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!"                                 '<<<< Modified
'
Application.StatusBar = False                           '<<<< Restore status bar
End Sub

Change the value of IsOE to True, or to False, or to 3 (Note that yesterday I suggested True /False or 0; but “0” is incorrect) to have a list that includes only Odd numbers, or Even numbers, or any number.


When you need to check that the combination include or exclude a certain number of a certain list then the second suggestion come to work.
This works either with your original macro or with the macro modified to draw only even or odds; if you don’t need to combine the two features then I suggest you apply it on your original macro.

This is the macro that I assembled:

Sub List6of37ViaArrayCheck()
'
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
'
lArray = Array(1, 2, 3, 4, 5, 6, 20, 21, 22, 23)        '<<< YOUR Array, see Your If ahead
'
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
    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
                        'Check the resulting combination:
                        Ball_Sum = 0
                        If Not IsError(Application.Match(Ball_1, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_2, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_3, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_4, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_5, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_6, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        '
                        If Ball_Sum > 2 Then          '<<< YOUR If, based on your Array
                        '
                            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
                        End If
                    Next Ball_6
                Next Ball_5
            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!"                                     '<<<< Modified
'
Application.StatusBar = False                           '<<<< Restore status bar
End Sub

There are two lines that YOU need to compile according your need:
The line lArray = Array(etc etc

and later on:
If Ball_Sum > 2 Then

lArray has to be populated with the numbers you wish that the combination will be tested against

The If … Then should reflect how the combination has to match the array in order to be approved

For example:
-if you need that the combination contains at least 3 of the figures in the array, you will use

If Ball_Sum >= 3 Then

If it’s still unclear how to work with the above set of codes, just ask

 

[excelNewbie22]

t-h-a-n-k y-o-u for your patience !

run the first macro (typo in line 13) and it worked,
it generate all combinations with odd numbers only,
but this isn't what i meant/asked
i meant to generate all combinations, which is 2324784, without/exclude the only even ones or odd ones
example for even only: 2-4-6-12-30-32 and for odd only: 1-11-21-29-33-35
so delete from all 2324784 combinations these kind of combinations
and keep all other ones (mix of even and odd ones, like 1-2-4-6-8-10 or 5-7-8-10-11-13)

although now i understand, thank you again for explaining
the second macro doesn't work
i run it, it thinks for couple of seconds, and then nothing change in the worksheet

this is what i run

Sub List6of37ViaArrayCheck()
'
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
'
lArray = Array(1, 2, 3, 4, 5, 6)        '<<< YOUR Array, see Your If ahead
'
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
    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
                        'Check the resulting combination:
                        Ball_Sum = 0
                        If Not IsError(Application.Match(Ball_1, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_2, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_3, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_4, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_5, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        If Not IsError(Application.Match(Ball_6, lArray, False)) Then Ball_Sum = Ball_Sum + 1
                        '
                        If Ball_Sum > 1 Then          '<<< YOUR If, based on your Array
                        '
                            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
                        End If
                    Next Ball_6
                Next Ball_5
            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!"                                     '<<<< Modified
'
Application.StatusBar = False                           '<<<< Restore status bar
End Sub

 

[Anthony47]

i meant to generate all combinations, which is 2324784, without/exclude the only even ones or odd ones
example for even only: 2-4-6-12-30-32 and for odd only: 1-11-21-29-33-35
so delete from all 2324784 combinations these kind of combinations
and keep all other ones (mix of even and odd ones, like 1-2-4-6-8-10 or 5-7-8-10-11-13)

For this purspose, use the second macro, in three versions:
1) set lArray for containing all the odd numbers (1,3,..37)
Then use

If Ball_Sum <6 then

2) a second macro with only even numbers in lArray
Then use the same If Ball_Sum <6 then

I have no any new suggestion for the third version of the macro, that means a different array and a different If ... Then

the second macro doesn't work
i run it, it thinks for couple of seconds, and then nothing change in the worksheet

The macro needs many many seconds to complete; initially the worksheet is cleared and you will not see any change until the macro completes; the status bar show in small characters how it advance every 550000 lines, that is every many seconds. You could increase the frequency of this updating using If CombinationCounter Mod 50000 Then (instead 550000)
A msgbox will inform about the macro completion