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

 

[ciscoaudrey]

Ok just finished running your code. Its all working perfectly. Yes id does take 50 seconds more than the other code. It finished at 148.90625 seconds. Thank you very much for the help on this Johnny....

 

[johnnyL]

Glad to help.

 

[johnnyL]

Ok. I am always looking for ways to speed up code, be it my code or somebody else.

I restructured the most recent code I submitted, (Post #19), & the result actually runs a bit faster than the original code I submitted in Post #11.

Please give it a go & let me know your results.

Sub MegaMillionsAllCombinations_OneCellEach_SmallerArrays()
'
    Dim StartTime               As Double
    StartTime = Timer
'
    Dim ArrayRanges             As Long, RangeCount             As Long
    Dim AmountOfNumbersChosen   As Long, MaxAmountOfNumbers     As Long
    Dim DisplayColumn           As Long, DisplayRow             As Long
    Dim MaxArrayRows            As Long
    Dim OutputColumn            As Long
    Dim StartOutputColumn       As Long
    Dim SourceRow               As Long, OutputRow              As Long
    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
        StartOutputColumn = 1                                                           ' <--- Set this to the column to start displaying data to
'
' 1000000 is the maximum MaxArrayRows suggested
' It is recommended that the following value be set to value that is
' easily divisible by 1000000. Ie. 1M, 500k, 250k, 125k, 100k, 50k, 25k, 20k, 10k, 5k
    MaxArrayRows = 1000000                                                              ' <--- Set this to the MaxArrayRows in the OutputArray
'
    ActiveSheet.UsedRange.ClearContents                                                 ' Clear any previous results from sheet
'
    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
'
    HeaderArray = Array("5 Ball Combinations", "Mega Ball")                             ' Establish array of Headers to write to sheet
'
    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
'
    ActiveSheet.UsedRange.EntireColumn.AutoFit                                          ' Set the width of the columns to be used
'
'---------------------------------------------------------------------------------------
'
    ReDim OutputArray(1 To MaxArrayRows, 1 To 1)                                        ' Set the # of rows & columns for the OutputArray
'
    DisplayColumn = 1                                                                   ' Initialize DisplayColumn
    DisplayRow = 2                                                                      ' Initialize DisplayRow
    OutputRow = 1                                                                       ' Initialize the OutputRow
    SourceRow = 0                                                                       ' Initialize SourceRow
    OutputColumn = 1                                                                    ' Initialize the OutputColumn
'
    For SourceRow = 1 To UBound(SourceArray, 1)                                         ' Loop through all generated 5 ball combinations of 70 balls total
        OutputArray(OutputRow, OutputColumn) = SourceArray(SourceRow, 1) & _
                "-" & SourceArray(SourceRow, 2) & "-" & SourceArray(SourceRow, 3) & _
                "-" & SourceArray(SourceRow, 4) & "-" & SourceArray(SourceRow, 5)       '   Save combined numbers and delimeters to OutputArray
'
        OutputRow = OutputRow + 1                                                       '   Increment the OutputRow
'
        If OutputRow > MaxArrayRows Then                                                '   If we have copied 50k data rows to OutputArray then ...
            OutputRow = 1                                                               '       Reset OutputRow
'
            Application.ScreenUpdating = False                                          '       Turn ScreenUpdating off
            Cells(DisplayRow, DisplayColumn).Resize(UBound(OutputArray, 1), _
                    UBound(OutputArray, 2)) = OutputArray                               '       Display results to sheet
            Application.ScreenUpdating = True                                           '       Turn ScreenUpdating back on
'
            DoEvents                                                                    '       Allow sheet to display current written data
'
            ReDim OutputArray(1 To MaxArrayRows, 1 To 1)                                '       Set the # of rows & columns for the OutputArray
'
            DisplayRow = DisplayRow + MaxArrayRows                                      '       Increment DisplayRow
'
            If Cells(Rows.Count, DisplayColumn).End(xlUp).Row > 1000000 Then            '       If sheet column is full then ...
                DisplayRow = 2                                                          '           Reset DisplayRow
                DisplayColumn = DisplayColumn + 3                                       '           Increment the DisplayColumn
            End If
        End If
    Next                                                                                ' Loop back
'
    If OutputRow > 1 Then                                                               ' If there are more results to display then ...
        Application.ScreenUpdating = False                                              '   Turn ScreenUpdating off
        Cells(DisplayRow, DisplayColumn).Resize(OutputRow - 1, _
                UBound(OutputArray, 2)) = OutputArray                                   '   Display remaining results to sheet
        Application.ScreenUpdating = True                                               '   Turn ScreenUpdating back on
    End If
'
    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