Please modify the code for 5_50 lottery with specifics odd even conditions.

[Kishan]

Using Excel 2000

Hi,

@johnnyL, I found your code which work perfect with my version 2000 as it is designed. Please does it is possible could be adapted for the lottery Euromillones 5_50 “5 balls out of 50”

Also I need bit more specific Odd/Even condition by their “5 positions” to generate the combinations. Conditions simple sheet with 3 examples is attached below.

Kishan Index.xlsx
	A	B	C	D	E	F	G	H
1
2			Position-1	Position-2	Position-3	Position-4	Position-5
3		Example1	ODD	ODD	ODD	ODD	ODD
4		Out Put	1	3	5	7	9
5
6			Position-1	Position-2	Position-3	Position-4	Position-5
7		Example2	EVEN	ODD	ODD	EVEN	EVEN
8		Out Put	2	9	15	48	50
9
10			Position-1	Position-2	Position-3	Position-4	Position-5
11		Example3	EVEN	EVEN	EVEN	ODD	ODD
12		Out Put	2	12	22	39	49
13
Hoja15

@johnnyL, code from below link.
Excel List All Lottery Combinations - 2441

Sub ListThemAllViaArray()
'
    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 CombinationCounter              As Long
    Dim MaxRows                         As Long, ThisRow  As Long
    Dim MaxWhiteBallValue               As Long
    Dim TotalExpectedCominations        As Long
    Dim ThisColumn                      As Long
    Dim CombinationsArray(1 To 65536)   As Variant
'
    MaxWhiteBallValue = 44                                                                                  ' <--- Set to highest value of white ball
'
    ArraySlotCount = 0                                                                                      ' Initialize ArraySlotCount
    CombinationCounter = 1                                                                                  ' Initialize CombinationCounter
    MaxRows = 65536                                                                                         ' Set to maximum number of slots in Array
    ThisColumn = 1                                                                                          ' Initialize 1st column to display results in
    ThisRow = 0                                                                                             ' Initialize row counter
    TotalExpectedCominations = 7059052                                                                      ' Set 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) = Ball_1 & "-" & Ball_2 & "-" & Ball_3 & "-" & Ball_4 & "-" & Ball_5 & "-" & Ball_6
                            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)) = Application.Transpose(CombinationsArray)
'
                                Erase CombinationsArray                                                     '                           Erase contents of array
                                ArraySlotCount = 0                                                          '                           Reset ArraySlotCount
                                ThisRow = 0                                                                 '                           Reset row counter
                                ThisColumn = ThisColumn + 1                                                 '                           Increment column counter
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
'
    Range(Cells(1, ThisColumn), Cells(ThisRow, ThisColumn)) = Application.Transpose(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
End Sub

Thank you in advance

Regards,
Kishan

 

[johnnyL]

This lottery, statistically speaking should be 'easy' compared to other lotteries.

Book1
	A	B	C	D
1	Lottery Name	Odds	Balls Drawn
2	Euro Millions	139,838,160	5 out of 50, then 2 out of 12
3	Powerball	292,201,338	5 out of 69, then 1 out of 26
4	Mega Millions	302,575,350	5 out of 70, then 1 out of 25
5
Sheet1

Cell Formulas
Range	Formula
B2	B2	= COMBIN(50,5) * COMBIN(12,2)
B3	B3	= COMBIN(69,5) * COMBIN(26,1)
B4	B4	= COMBIN(70,5) * COMBIN(25,1)

I, however, am not sure what you are looking for based on your OP.

Can you post some more data of what you will be starting with and what you hope to end up with?

 

[Kishan]

This lottery, statistically speaking should be 'easy' compared to other lotteries.

Book1
	A	B	C	D
1	Lottery Name	Odds	Balls Drawn
2	Euro Millions	139,838,160	5 out of 50, then 2 out of 12
3	Powerball	292,201,338	5 out of 69, then 1 out of 26
4	Mega Millions	302,575,350	5 out of 70, then 1 out of 25
5
Sheet1

Cell Formulas
Range	Formula
B2	B2	= COMBIN(50,5) * COMBIN(12,2)
B3	B3	= COMBIN(69,5) * COMBIN(26,1)
B4	B4	= COMBIN(70,5) * COMBIN(25,1)

Hi johnnyL, thank you for your replies yes it is correct total Odds Euro Millions will be 2118760 without counting the 2 stars.

I, however, am not sure what you are looking for based on your OP.

Can you post some more data of what you will be starting with and what you hope to end up with?

Yes sure for example in the range D6:H26 I got some draw result, in the range J6:N26 there is shown draw Odd/Even numbers by their positions… and there could be 32 unique patterns of Odd/Even which are shown in the range Q6:U37….

What I want a macro can generate combination by 5 individual Odd/Even positions….

Now say for example I want to generate pattern 10th combination O-E-O-O-E when macro executed ask for individual by input or that pattern could be placed in range Q1:U1…if it is by input so macro ask….

1st input O/E… answer O

2nd input O/E… answer E

3rd input O/E… answer O

4th input O/E… answer O

5th input O/E… answer E….and the macro generate all combination according O/E Inputs.

Hope this clarify if any further question please ask me.

Kishan Index.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1																10	O	E	O	O	E
2
3				Position-1	Position-2	Position-3	Position-4	Position-5		Position-1	Position-2	Position-3	Position-4	Position-5			Position-1	Position-2	Position-3	Position-4	Position-5
4				n1	n2	n3	n4	n5		Unique	Unique	Unique	Unique	Unique		Total	Unique	Unique	Unique	Unique	Unique
5				n1	n2	n3	n4	n5		Odd/Even	Odd/Even	Odd/Even	Odd/Even	Odd/Even		Pattern	Odd/Even	Odd/Even	Odd/Even	Odd/Even	Odd/Even
6				16	29	32	36	41		E	O	E	E	O		1	O	O	O	O	O
7				7	13	39	47	50		O	O	O	O	E		2	O	O	O	O	E
8				14	18	19	31	37		E	E	O	O	O		3	O	O	O	E	O
9				4	7	33	37	39		E	O	O	O	O		4	O	O	O	E	E
10				15	24	28	44	47		O	E	E	E	O		5	O	O	E	O	O
11				33	36	37	42	45		O	E	O	E	O		6	O	O	E	O	E
12				3	4	10	23	43		O	E	E	O	O		7	O	O	E	E	O
13				4	12	24	27	36		E	E	E	O	E		8	O	O	E	E	E
14				1	4	10	19	23		O	E	E	O	O		9	O	E	O	O	O
15				14	15	28	35	40		E	O	E	O	E		10	O	E	O	O	E
16				6	10	21	45	49		E	E	O	O	O		11	O	E	O	E	O
17				5	6	16	23	27		O	E	E	O	O		12	O	E	O	E	E
18				15	16	21	36	38		O	E	O	E	E		13	O	E	E	O	O
19				1	3	21	32	39		O	O	O	E	O		14	O	E	E	O	E
20				15	29	37	39	49		O	O	O	O	O		15	O	E	E	E	O
21				6	11	35	41	44		E	O	O	O	E		16	O	E	E	E	E
22				9	13	34	41	42		O	O	E	O	E		17	E	E	E	E	E
23				2	7	8	10	47		E	O	E	E	O		18	E	E	E	E	O
24				2	23	28	40	43		E	O	E	E	O		19	E	E	E	O	E
25				3	21	30	34	35		O	O	E	E	O		20	E	E	E	O	O
26				4	23	24	28	34		E	O	E	E	E		21	E	E	O	E	E
27																22	E	E	O	E	O
28																23	E	E	O	O	E
29																24	E	E	O	O	O
30																25	E	O	E	E	E
31																26	E	O	E	E	O
32																27	E	O	E	O	E
33																28	E	O	E	O	O
34																29	E	O	O	E	E
35																30	E	O	O	E	O
36																31	E	O	O	O	E
37																32	E	O	O	O	O
38
39
Hoja2

Cell Formulas
Range	Formula
J6:N26	J6	=IF($D6="","",IF(ISODD(D6),"O","E"))

Regards,
Kishan

 

[johnnyL]

I am still trying to understand what you are wanting to do.

Are you wanting to select one of the 32 permutations of the 'O'/'E'' and have the code spit out those results?

 

[Kishan]

I am still trying to understand what you are wanting to do.

Hi johnnyL, thank you for asking a question.

Are you wanting to select one of the 32 permutations of the 'O'/'E'' and have the code spit out those results?

Yes your thought and answer is correct. I want as for in the example 1 of 32 permutations nº 10 is selected which is O-E-O-O-E so code split out those result as for example shown below in the range D6:H63 all result match with selected as per nº 10 permutations

Please if need any further clarification please let me know thank you.

Kishan Index.xlsx
	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1													10	O	E	O	O	E
2	O	E	O	O	E
3	Position-1	Position-2	Position-3	Position-4	Position-5		Position-1	Position-2	Position-3	Position-4	Position-5			Position-1	Position-2	Position-3	Position-4	Position-5
4	Result	Result	Result	Result	Result		Unique	Unique	Unique	Unique	Unique		Total	Unique	Unique	Unique	Unique	Unique
5	n1	n2	n3	n4	n5		Odd/Even	Odd/Even	Odd/Even	Odd/Even	Odd/Even		Pattern	Odd/Even	Odd/Even	Odd/Even	Odd/Even	Odd/Even
6	1	2	3	5	6		O	E	O	O	E		1	O	O	O	O	O
7	1	4	5	7	8		O	E	O	O	E		2	O	O	O	O	E
8	1	6	7	9	10		O	E	O	O	E		3	O	O	O	E	O
9	1	8	9	11	12		O	E	O	O	E		4	O	O	O	E	E
10	1	10	11	13	14		O	E	O	O	E		5	O	O	E	O	O
11	1	12	13	15	16		O	E	O	O	E		6	O	O	E	O	E
12	1	14	15	17	18		O	E	O	O	E		7	O	O	E	E	O
13	1	16	17	19	20		O	E	O	O	E		8	O	O	E	E	E
14	1	18	19	21	22		O	E	O	O	E		9	O	E	O	O	O
15	1	20	21	23	24		O	E	O	O	E		10	O	E	O	O	E
16	1	22	23	25	26		O	E	O	O	E		11	O	E	O	E	O
17	1	24	25	27	28		O	E	O	O	E		12	O	E	O	E	E
18	1	26	27	29	30		O	E	O	O	E		13	O	E	E	O	O
19	1	28	29	31	32		O	E	O	O	E		14	O	E	E	O	E
20	1	30	31	33	34		O	E	O	O	E		15	O	E	E	E	O
21	1	32	33	35	36		O	E	O	O	E		16	O	E	E	E	E
22	1	34	35	37	38		O	E	O	O	E		17	E	E	E	E	E
23	1	36	37	39	40		O	E	O	O	E		18	E	E	E	E	O
24	1	38	39	41	42		O	E	O	O	E		19	E	E	E	O	E
25	1	40	41	43	44		O	E	O	O	E		20	E	E	E	O	O
26	1	42	43	45	46		O	E	O	O	E		21	E	E	O	E	E
27	1	44	45	47	48		O	E	O	O	E		22	E	E	O	E	O
28	1	46	47	49	50		O	E	O	O	E		23	E	E	O	O	E
29	3	4	5	7	8		O	E	O	O	E		24	E	E	O	O	O
30	3	6	7	9	10		O	E	O	O	E		25	E	O	E	E	E
31	3	8	9	11	12		O	E	O	O	E		26	E	O	E	E	O
32	3	10	11	13	14		O	E	O	O	E		27	E	O	E	O	E
33	3	12	13	15	16		O	E	O	O	E		28	E	O	E	O	O
34	3	14	15	17	18		O	E	O	O	E		29	E	O	O	E	E
35	3	16	17	19	20		O	E	O	O	E		30	E	O	O	E	O
36	3	18	19	21	22		O	E	O	O	E		31	E	O	O	O	E
37	3	20	21	23	24		O	E	O	O	E		32	E	O	O	O	O
38	3	22	23	25	26		O	E	O	O	E
39	3	24	25	27	28		O	E	O	O	E
40	3	26	27	29	30		O	E	O	O	E
41	3	28	29	31	32		O	E	O	O	E
42	3	30	31	33	34		O	E	O	O	E
43	3	32	33	35	36		O	E	O	O	E
44	3	34	35	37	38		O	E	O	O	E
45	3	36	37	39	40		O	E	O	O	E
46	3	38	39	41	42		O	E	O	O	E
47	3	40	41	43	44		O	E	O	O	E
48	3	42	43	45	46		O	E	O	O	E
49	3	44	45	47	48		O	E	O	O	E
50	3	46	47	49	50		O	E	O	O	E
51	3	6	7	9	10		O	E	O	O	E
52	3	8	9	11	12		O	E	O	O	E
53	3	10	11	13	14		O	E	O	O	E
54	3	12	13	15	16		O	E	O	O	E
55	3	14	15	17	18		O	E	O	O	E
56	3	16	17	19	20		O	E	O	O	E
57	3	18	19	21	22		O	E	O	O	E
58	3	20	21	23	24		O	E	O	O	E
59	3	22	23	25	26		O	E	O	O	E
60	3	24	25	27	28		O	E	O	O	E
61	3	26	27	29	30		O	E	O	O	E
62	3	28	29	31	32		O	E	O	O	E
63	3	30	31	33	34		O	E	O	O	E
Hoja3

Cell Formulas
Range	Formula
J6:N63	J6	=IF($D6="","",IF(ISODD(D6),"O","E"))

Regards,
Kishan

 

[johnnyL]

Ok, I pretty much have this resolved, so I am going to ask what you want the final output to look like. I personally don't see any reason for the columns of J:N.

Do you really need 50k to 80k rows of the same data in that range? I can understand you wanting to show it during potential troubleshooting, but after the code is confirmed as working, I see no need for those columns.

As far as the Header rows in D2:H5 ... Do you really need all of those rows?

Let me know what can be trimmed, or if you want to keep it exactly like you are showing it.

 

[Kishan]

Ok, I pretty much have this resolved, so I am going to ask what you want the final output to look like. I personally don't see any reason for the columns of J:N.

Do you really need 50k to 80k rows of the same data in that range? I can understand you wanting to show it during potential troubleshooting, but after the code is confirmed as working, I see no need for those columns.

Hi johnnyL, thank you for asking the questions, I agree this I make only to show example look clearer. It is perfect there is no need of columns J:N at all.

As far as the Header rows in D2:H5 ... Do you really need all of those rows?

Let me know what can be trimmed, or if you want to keep it exactly like you are showing it.

Yes all these can be removed I do not want nothing look like as shown them in the given example. I just showed all to understand my view bit clearer in the detail.

As it is all very clear to you, so far I just want code to generate all the combinations in a single column or I guess it will be much better if possible in a 5 different columns. Or as you have thought to design it will be ok for me.

NOTE: I got max row 65000 in version 2000 if combinations are more than 65k it must go to next columns…please if any question I am happy to reply.

Regards,
Kishan

 

[johnnyL]

Well I can't test Excel 2000, but the following codes are what I have come up with thus far, I guess you will have to report back to us how well you fair when testing the codes with Excel 2000.

To test the (32) permutations of 5 by 2 ... 5 ^ 2 ... you can test test the following code to generate those combinations by placing the following codes into a regular module:

Sub Generate_O_And_E_Permutations()
'
    Dim OddEvenArray                As Variant
    Dim CurrentPermutationArray     As Variant
    Dim PermutationArray()          As Variant
    Dim ws                          As Worksheet
'
    Const BallsToDraw As Long = 5                                                       '
'
    Set ws = Sheets("Hoja2")                                                            ' <--- Set this to the name of the sheet that the data will go in
'
    OddEvenArray = Array("O", "E")                                                      ' Set the options for the array to choose from
'
    ReDim CurrentPermutationArray(1 To BallsToDraw)                                     ' Establish the CurrentPermutationArray
    ReDim PermutationArray(1 To (UBound(OddEvenArray) + 1) ^ BallsToDraw, _
            1 To BallsToDraw)                                                           ' Establish the PermutationArray
'
    Call GeneratePermutationsRecursive(OddEvenArray, CurrentPermutationArray, 1, _
            BallsToDraw, PermutationArray, 1)                                           ' Call the recursive subroutine
'
    ws.Range("Q6").Resize(UBound(PermutationArray, 1), _
            UBound(PermutationArray, 2)).Value2 = PermutationArray                      ' Display the PermutationArray to the sheet
End Sub

Sub GeneratePermutationsRecursive(OddEvenArray As Variant, _
        CurrentPermutation As Variant, CurrentPosition As Long, TotalPositions As Long, _
        PermutationArray() As Variant, ByRef OutputIndex As Long)                       '
'
    Dim i As Long                                                                       '
'
    If CurrentPosition > TotalPositions Then                                            '
        For i = 1 To TotalPositions                                                     '
            PermutationArray(OutputIndex, i) = CurrentPermutation(i)                    '
        Next                                                                            '
'
        OutputIndex = OutputIndex + 1                                                   '
        Exit Sub                                                                        '
    End If
'
    For i = 0 To UBound(OddEvenArray)                                                   '
        CurrentPermutation(CurrentPosition) = OddEvenArray(i)                           '
'
        Call GeneratePermutationsRecursive(OddEvenArray, CurrentPermutation, _
                CurrentPosition + 1, TotalPositions, PermutationArray, OutputIndex)     '
    Next                                                                                '
End Sub

To test the code that I think you are most interested in:

Copy the following code to the worksheet module that the data is located in:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
    Dim ColumnNumber    As Long
    Dim SelectedCell    As Range, SelectedRow   As Range
    Dim OddEvenString   As String
'
    Const BallsToDraw As Long = 5                                                       ' <--- Set this to the # of balls to be drawn each iteration
'
    If Target.CountLarge > 1 Then Exit Sub                                              ' If multiple cells selected at once then exit sub
'
    Set SelectedRow = Intersect(Target, Range("P6:P37"))                                ' Check if the selected range intersects with the range P6:P37
'
    If Not SelectedRow Is Nothing Then                                                  ' If a monitored cell was selected then ...
        Set SelectedCell = Intersect(Target, SelectedRow)                               '   Get the selected cell within the range P6:P37
'
        For ColumnNumber = 1 To BallsToDraw                                             '   Loop through the values from the 5 columns to the right of the selected cell
            Range("D2").Offset(0, ColumnNumber - 1).Value2 = SelectedCell.Offset(0, _
                    ColumnNumber).Value2                                                '   Save all of the values from the 5 columns to the right of the selected cell to the sheet
            OddEvenString = OddEvenString & SelectedCell.Offset(0, ColumnNumber).Value2 '       Save all of the values from the 5 columns to the right of the selected cell to OddEvenString
        Next                                                                            '   Loop back
'
        Call List5of50ByOddAndEvenDesignation(OddEvenString)                            '   Call the subroutine and pass the selected values
    End If
End Sub

Then in a regular module, copy the following codes:

Option Explicit


Sub List5of50ByOddAndEvenDesignation(ByVal OddEvenString As String)
'
    Dim Ball_1                      As Long, Ball_2     As Long, Ball_3     As Long, Ball_4     As Long, Ball_5     As Long
    Dim CombinationCounter          As Long
    Dim OutputColumnNumber          As Long
    Dim Ball_1_Test                 As String, Ball_2_Test  As String, Ball_3_Test  As String, Ball_4_Test  As String, Ball_5_Test  As String
    Dim OddEvenCompareString        As String
    Dim CombinationArray()          As Variant
    Dim ws                          As Worksheet
'
    Const BallsToDraw As Long = 5                                                       ' <--- Set this to the # of balls to be drawn each iteration
    Const MaxWhiteBallValue As Long = 50                                                ' <--- Set this to the maximum # of balls being used
'
    Set ws = Sheets("Hoja2")                                                            ' <--- Set this to the name of the sheet that the data will go in
'
    OutputColumnNumber = 4                                                              ' <--- Set this the the # of the column to display results into
'
    ws.Range("D6:H" & Rows.Count).ClearContents                                         ' Clear the previous results
'
    ReDim CombinationArray(1 To Rows.Count, 1 To 5)                                     ' Establish the initial dimensions of the CombinationArray
'
    Application.ScreenUpdating = False                                                  ' Turn ScreenUpdating off
'
    For Ball_1 = 1 To MaxWhiteBallValue - 4                                             ' Loop for Ball_1 value
        For Ball_2 = Ball_1 + 1 To MaxWhiteBallValue - 3                                '   Loop for Ball_2 value
            For Ball_3 = Ball_2 + 1 To MaxWhiteBallValue - 2                            '       Loop for Ball_3 value
                For Ball_4 = Ball_3 + 1 To MaxWhiteBallValue - 1                        '           Loop for Ball_4 value
                    For Ball_5 = Ball_4 + 1 To MaxWhiteBallValue                        '               Loop for Ball_5 value
                        If Ball_1 Mod 2 = 0 Then                                        '                   If Ball_1 value is an even number then ...
                            Ball_1_Test = "E"                                           '                       Save 'E' to Ball_1_Test
                        Else                                                            '                   Else ...
                            Ball_1_Test = "O"                                           '                       Save 'O' to Ball_1_Test
                        End If
'
                        If Ball_2 Mod 2 = 0 Then                                        '                   If Ball_2 value is an even number then ...
                            Ball_2_Test = "E"                                           '                       Save 'E' to Ball_2_Test
                        Else                                                            '                   Else ...
                            Ball_2_Test = "O"                                           '                       Save 'O' to Ball_2_Test
                        End If
'
                        If Ball_3 Mod 2 = 0 Then                                        '                   If Ball_3 value is an even number then ...
                            Ball_3_Test = "E"                                           '                       Save 'E' to Ball_3_Test
                        Else                                                            '                   Else ...
                            Ball_3_Test = "O"                                           '                       Save 'O' to Ball_3_Test
                        End If
'
                        If Ball_4 Mod 2 = 0 Then                                        '                   If Ball_4 value is an even number then ...
                            Ball_4_Test = "E"                                           '                       Save 'E' to Ball_4_Test
                        Else                                                            '                   Else ...
                            Ball_4_Test = "O"                                           '                       Save 'O' to Ball_4_Test
                        End If
'
                        If Ball_5 Mod 2 = 0 Then                                        '                   If Ball_5 value is an even number then ...
                            Ball_5_Test = "E"                                           '                       Save 'E' to Ball_5_Test
                        Else                                                            '                   Else ...
                            Ball_5_Test = "O"                                           '                       Save 'O' to Ball_5_Test
                        End If
'
                        OddEvenCompareString = Ball_1_Test & Ball_2_Test & _
                                Ball_3_Test & Ball_4_Test & Ball_5_Test                 '                   Save all of the individual 'O's & 'E's into OddEvenCompareString
'
                        If OddEvenCompareString = OddEvenString Then                    '                   If OddEvenCompareString matches the string we are looking for then ...
                            CombinationCounter = CombinationCounter + 1                 '                       Increment CombinationCounter
'
                            CombinationArray(CombinationCounter, 1) = Ball_1            '                       Save Ball_1 into the CombinationArray
                            CombinationArray(CombinationCounter, 2) = Ball_2            '                       Save Ball_2 into the CombinationArray
                            CombinationArray(CombinationCounter, 3) = Ball_3            '                       Save Ball_3 into the CombinationArray
                            CombinationArray(CombinationCounter, 4) = Ball_4            '                       Save Ball_4 into the CombinationArray
                            CombinationArray(CombinationCounter, 5) = Ball_5            '                       Save Ball_5 into the CombinationArray
                        End If
                    Next Ball_5                                                         '               Loop back
                Next Ball_4                                                             '           Loop back
            Next Ball_3                                                                 '       Loop back
        Next Ball_2                                                                     '   Loop back
    Next Ball_1                                                                         ' Loop back
'
    CombinationArray = ReDimPreserve(CombinationArray, CombinationCounter, BallsToDraw) ' Resize the CombinationArray to the actual # of rows used
'
' Output combinations
    ws.Cells(6, OutputColumnNumber).Resize(UBound(CombinationArray, 1), BallsToDraw).Value2 _
            = CombinationArray                                                          ' Display the CombinationArray to the sheet
'
    Application.ScreenUpdating = True                                                   ' Turn ScreenUpdating back on
End Sub


Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve Original data & LBounds & Redim both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
    Dim NewColumn                   As Long, NewRow                      As Long
    Dim OldColumnLbound             As Long, OldRowLbound                As Long
    Dim OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewResizedArray()           As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToResize) Then                                                                      ' If the variable is an array then ...
           OldRowLbound = LBound(ArrayNameToResize, 1)                                                      '   Save the original row Lbound to OldRowLbound
        OldColumnLbound = LBound(ArrayNameToResize, 2)                                                      '   Save the original column Lbound to OldColumnLbound
'
        ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound)             '   Create a New 2D Array with same Lbounds as the original array
'
        OldRowUbound = UBound(ArrayNameToResize, 1)                                                         '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToResize, 2)                                                      '   Save column Ubound of original array
'
        For NewRow = OldRowLbound To NewRowUbound                                                           '   Loop through rows of original array
            For NewColumn = OldColumnLbound To NewColumnUbound                                              '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then                             '           If more data to copy then ...
                    NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn)               '               Append rows/columns to NewResizedArray
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase ArrayNameToResize                                                                             '   Free up the memory the Original array was taking
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function

Please let us know how that works out for you and we can work from there.

 

[johnnyL]

If you are truly limited to 65K row ... the following should result in less than that:

OOOOO = 53130
EOOOO = 53130
EEOOO = 53130
EEEOO = 53130
EEEEO = 53130
EEEEE = 53130

The other results can go up to about 80K which will need to be addressed, and you can let us know how you want to handle the results that are > 65K results.

 

[Kishan]

Well I can't test Excel 2000, but the following codes are what I have come up with thus far, I guess you will have to report back to us how well you fair when testing the codes with Excel 2000.

To test the (32) permutations of 5 by 2 ... 5 ^ 2 ... you can test test the following code to generate those combinations by placing the following codes into a regular module:

 Sub Generate_O_And_E_Permutations()

To test the code that I think you are most interested in:

Copy the following code to the worksheet module that the data is located in:

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Then in a regular module, copy the following codes:

Option Explicit
Sub List5of50ByOddAndEvenDesignation(ByVal OddEvenString As String)

Please let us know how that works out for you and we can work from there.

Hi johnnyL, I need your help please guide me…

1-”Sub Generate_O_And_E_Permutations()” this worked fine created permutations in the “Hoja2”

2-“Private Sub Worksheet_SelectionChange(ByVal Target As Range)”this code I paste in “Hoja3” where data is located in:

3-“Sub List5of50ByOddAndEvenDesignation(ByVal OddEvenString As String)” pasted in the regular module…But I cannot run it.

Please can you tell me what I am doing wrong?

Thank you

Regards,
Kishan