Mega Millions All combinations

[ciscoaudrey]

Hello to all first of all. I was following a thread about mrexcel and running a script to generate into excel all possible combinations of US mega millions lottery. Yes i know what your thinking; But WHYYYYYYYYYYYYYYYYYYYY? Theres over 300 million combinations. Well honestly, Why not? Once i have them, later on in the near future i will be implementing some type of number analysis with that list and the already drawn numbers from past history. So i was advised by JohnnyL at thread 2441 to post a new thread so here it is. Title of that thread was Excel List All Lottery Combinations-2441. So JohnnyL, after using your first code and modifying just a few things to work with mega millions I got some issues. First thing is it will not print combinations past the 65,536 cell, after that it displays #N/A on every cell all the way to 1,048,576 then on column B1 combinations continue where 1,048,576 should of left off. So I then changed parameters on the code on combinationsArray to 65536 how your original code was and max combinations it goes to is 280,500,000 where total should be the 302,575,350 possibilities, unless I'm mistaken. It stops at combo 65,66,67,68,69,25. Can you or anyone help me on this issue, I'm new to programming and doing this just to have the entire combination's list. By the way I did try the code that mr excel put in the first post but computer never finishes its been like one 3 days straight and only at about 30 million combinations but it works and prints the way it should.


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 1048576) As Variant
'
MaxWhiteBallValue = 70 ' <--- Set to highest value of white ball
'
ArraySlotCount = 0 ' Initialize ArraySlotCount
CombinationCounter = 1 ' Initialize CombinationCounter
MaxRows = 1048576 ' Set to maximum number of slots in Array
ThisColumn = 1 ' Initialize 1st column to display results in
ThisRow = 0 ' Initialize row counter
TotalExpectedCominations = 302,575,350 ' 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 = 1 To 25 ' 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 & " out of " & 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

 

[johnnyL]

I did some restructuring and shaved some time (about 16%)

Sub MegaMillionsAllCombinations()
'
    Dim StartTime               As Double
    StartTime = Timer
'
    Dim ArrayRanges             As Long, RangeCount             As Long
    Dim AmountOfNumbersChosen   As Long, MaxAmountOfNumbers     As Long
    Dim SourceColumn            As Long, OutputColumn           As Long, StartOutputColumn      As Long
    Dim SourceRow               As Long, OutputRow              As Long
    Dim OutputArray()           As Long, SourceArray()          As Long
    Dim HeaderArray             As Variant
'
    AmountOfNumbersChosen = 5                                                           ' <--- Set this to the AmountOfNumbersChosen
    MaxAmountOfNumbers = 70                                                             ' <--- Set this to the MaxAmountOfNumbers
'
    SourceArray = GetCombinations(MaxAmountOfNumbers, AmountOfNumbersChosen)            ' Load SourceArray with all non repeating 5 out of 70 combinations
'
' Time to generate all combinations = 6.713541666666667 Seconds.
'
'---------------------------------------------------------------------------------------
'
    ArrayRanges = Application.WorksheetFunction.RoundUp(UBound(SourceArray, 1) _
            / 1000000, 0)                                                               ' Calculate # of loops needed to cycle through all combos
'
    ReDim OutputArray(1 To 1000000, 1 To (AmountOfNumbersChosen + 2) * ArrayRanges)     ' Set the # of rows & columns needed for the OutputArray
'
    OutputRow = 1                                                                       ' Initialize the OutputRow
    StartOutputColumn = 1                                                               ' Initialize the StartOutputColumn
'
    For SourceRow = 1 To UBound(SourceArray, 1)                                         ' Loop through all generated 5 ball combinations of 70 balls total
        OutputColumn = StartOutputColumn                                                '   Set the OutputColumn  = StartOutputColumn
'
        For SourceColumn = 1 To AmountOfNumbersChosen                                   '   Loop through the SourceArray columns
            OutputArray(OutputRow, OutputColumn) = SourceArray(SourceRow, SourceColumn) '       Load SourceArray combination data to OutputArray
'
            OutputColumn = OutputColumn + 1                                             '       Increment the OutputColumn
        Next                                                                            '   Loop back
'
        OutputRow = OutputRow + 1                                                       '   Increment the OutputRow
'
        If OutputRow > 1000000 Then                                                     '   If we have copied 1 million data rows to OutputArray then ...
            OutputRow = 1                                                               '       Reset OutputRow
            StartOutputColumn = StartOutputColumn + 7                                   '       Increment the StartOutputColumn
        End If
    Next                                                                                ' Loop back
'
' Time to create OutputArray = 4.786458333333333 Seconds.
'
'---------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = False                                                  ' Turn ScreenUpdating off
    ActiveSheet.UsedRange.ClearContents                                                 ' Clear any previous results
    Cells.NumberFormat = "0;-0;;@"                                                      ' Format the cells of the OutputSheet to hide zero values
'
    HeaderArray = Array("Ball 1", "Ball 2", "Ball 3", "Ball 4", "Ball 5", "Mega Ball")  ' Establish array of Headers to write to sheet
    StartOutputColumn = 1                                                               ' Initialize StartOutputColumn
'
    For RangeCount = 1 To ArrayRanges                                                   ' Loop through needed ranges of data
        Cells(1, StartOutputColumn).Resize(1, UBound(HeaderArray) + 1) = HeaderArray    '   Write the Header array to sheet for each range
        StartOutputColumn = StartOutputColumn + UBound(HeaderArray) + 2                 '   Increment the StartOutputColumn
    Next                                                                                ' Loop back
'
    Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray    ' Display results to sheet
'
'---------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = True                                                   ' Turn ScreenUpdating back on
'
    Debug.Print "Time to complete = " & Timer - StartTime & " seconds."                 ' Display time to complete to 'Immediate' window Ctrl+G in VBE
    MsgBox "Time to complete = " & Timer - StartTime & " seconds."                      ' Display time to complete in a message box
'
' Total Time to complete = 156.546875 seconds.
'
End Sub


Function GetCombinations(lNumber As Long, lNoChosen As Long) As Long()

    Dim lOutput() As Long, lCombinations As Long
    Dim i As Long, j As Long, k As Long
   
    lCombinations = WorksheetFunction.Combin(lNumber, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
   
    For i = 1 To lNoChosen
        lOutput(1, i) = i
    Next i
   
    For i = 2 To lCombinations
        For j = 1 To lNoChosen
            lOutput(i, j) = lOutput(i - 1, j)
        Next j
        For j = lNoChosen To 1 Step -1
            lOutput(i, j) = lOutput(i, j) + 1
            If lOutput(i, j) <= lNumber - (lNoChosen - j) Then Exit For
        Next j
        For k = j + 1 To lNoChosen
            lOutput(i, k) = lOutput(i, k - 1) + 1
        Next k
    Next i
   
    GetCombinations = lOutput
End Function

Time to generate all combinations = 6.713541666666667 seconds.
Time to create OutputArray = 4.786458333333333 seconds.
Time to display OutputArray = 156.546875 seconds.

 

[ciscoaudrey]

Very impressive Johnny, just ran this new code and my pc finished in 57.88671875 shaved off some seconds. I will look into this code more in depth as this 5 or 6 rows will be a bit harder to search than having them delimited by a hyphen and on one row each result. But I thank you for your help on this. You see how you got the Bug too, The Code Bug that is. Always trying to improve something that is already working. For me it was more of wanting to understand the code and why it wasnt working. Thanks again..

 

[ciscoaudrey]

disregard this post

 

[johnnyL]

It's there. It is in the last range specifically starting at CG103015.

Are you wanting all of the 5 ball combinations listed in one cell with '-' in between each number as opposed to one ball number in each cell?

 

[johnnyL]

Which makes sense being that there are 12,103,014 combinations total.

You have a sheet with 12 ranges of 1 million combinations each and the last range of 103,014 combinations + 1 header row which equals 103015.

 

[ciscoaudrey]

yes exactly separation of "-" on same cell. That just makes it easier to do a search for on this worksheet.

 

[johnnyL]

Ok, I will have a look at it shortly if nobody else responds in the mean time. If memory serves me correctly, it most likely will take longer to run due to the fact that strings will be used as opposed to just numbers.

 

[ciscoaudrey]

thanks johnny

 

[johnnyL]

Here is the code converted to put the 5 ball combinations into one cell. It does take longer, as I expected. Let me know your results.

Sub MegaMillionsAllCombinations_OneCellEach()
'
    Dim StartTime               As Double
    StartTime = Timer
'
    Dim ArrayRanges             As Long, RangeCount             As Long
    Dim AmountOfNumbersChosen   As Long, MaxAmountOfNumbers     As Long
    Dim SourceColumn            As Long, OutputColumn           As Long, StartOutputColumn      As Long
    Dim SourceRow               As Long, OutputRow              As Long
    Dim RowString               As String
    Dim OutputArray()           As String, SourceArray()          As Long
    Dim HeaderArray             As Variant
'
    AmountOfNumbersChosen = 5                                                           ' <--- Set this to the AmountOfNumbersChosen
    MaxAmountOfNumbers = 70                                                             ' <--- Set this to the MaxAmountOfNumbers
'
    SourceArray = GetCombinations(MaxAmountOfNumbers, AmountOfNumbersChosen)            ' Load SourceArray with all non repeating 5 out of 70 combinations
'
'---------------------------------------------------------------------------------------
'
    ArrayRanges = Application.WorksheetFunction.RoundUp(UBound(SourceArray, 1) _
            / 1000000, 0)                                                               ' Calculate # of loops needed to cycle through all combos
'
    ReDim OutputArray(1 To 1000000, 1 To (1 + 2) * ArrayRanges)                         ' Set the # of rows & columns needed for the OutputArray
'
    OutputRow = 1                                                                       ' Initialize the OutputRow
    StartOutputColumn = 1                                                               ' Initialize the StartOutputColumn
'
    For SourceRow = 1 To UBound(SourceArray, 1)                                         ' Loop through all generated 5 ball combinations of 70 balls total
        OutputColumn = StartOutputColumn                                                '   Set the OutputColumn  = StartOutputColumn
'
        OutputArray(OutputRow, OutputColumn) = SourceArray(SourceRow, 1) & _
                "-" & SourceArray(SourceRow, 2) & "-" & SourceArray(SourceRow, 3) & _
                "-" & SourceArray(SourceRow, 4) & "-" & SourceArray(SourceRow, 5)       '
'
        OutputArray(OutputRow, OutputColumn + 1) = " "
        OutputArray(OutputRow, OutputColumn + 2) = " "
'
        OutputRow = OutputRow + 1                                                       '   Increment the OutputRow
'
        If OutputRow > 1000000 Then                                                     '   If we have copied 1 million data rows to OutputArray then ...
            OutputRow = 1                                                               '       Reset OutputRow
            StartOutputColumn = StartOutputColumn + 3                                   '       Increment the StartOutputColumn
        End If
    Next                                                                                ' Loop back
'
'---------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = False                                                  ' Turn ScreenUpdating off
    ActiveSheet.UsedRange.ClearContents                                                 ' Clear any previous results
'
    HeaderArray = Array("5 Ball Combo", "Mega Ball")  ' Establish array of Headers to write to sheet
    StartOutputColumn = 1                                                               ' Initialize StartOutputColumn
'
    For RangeCount = 1 To ArrayRanges                                                   ' Loop through needed ranges of data
        Cells(1, StartOutputColumn).Resize(1, UBound(HeaderArray) + 1) = HeaderArray    '   Write the Header array to sheet for each range
        StartOutputColumn = StartOutputColumn + UBound(HeaderArray) + 2                 '   Increment the StartOutputColumn
    Next                                                                                ' Loop back
'
    Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray    ' Display results to sheet
'
''    ActiveSheet.UsedRange.EntireColumn.AutoFit
'
'---------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = True                                                   ' Turn ScreenUpdating back on
'
    Debug.Print "Time to complete = " & Timer - StartTime & " seconds."                 ' Display time to complete to 'Immediate' window Ctrl+G in VBE
    MsgBox "Time to complete = " & Timer - StartTime & " seconds."                      ' Display time to complete in a message box
End Sub


Function GetCombinations(lNumber As Long, lNoChosen As Long) As Long()

    Dim lOutput() As Long, lCombinations As Long
    Dim i As Long, j As Long, k As Long
   
    lCombinations = WorksheetFunction.Combin(lNumber, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
   
    For i = 1 To lNoChosen
        lOutput(1, i) = i
    Next i
   
    For i = 2 To lCombinations
        For j = 1 To lNoChosen
            lOutput(i, j) = lOutput(i - 1, j)
        Next j
'
        For j = lNoChosen To 1 Step -1
            lOutput(i, j) = lOutput(i, j) + 1
'
            If lOutput(i, j) <= lNumber - (lNoChosen - j) Then Exit For
        Next j
'
        For k = j + 1 To lNoChosen
            lOutput(i, k) = lOutput(i, k - 1) + 1
        Next k
    Next i
   
    GetCombinations = lOutput
End Function

 

[ciscoaudrey]

Thanks johnny will run it tonight.