Need help modify to pick any first number of my choice

M

motilulla

Well-known Member
Joined
Feb 13, 2008
Messages
2,422
Office Version
  1. 2010
Using Excel 2010
Hello,

@johnnyL, I found below code which generate all combinations from 1st to last set of 5 combinations. For 5_50 lottery

For example 1st 1-2-3-4-5 and last 46-47-48-49-50 total 2118760 combinations.

Does it is possible to modify so I can select 1st number of choice for example number “1” so it give me only all combination with number “1”. If 2 then with 3 if 3 then with 3 if I select 46 then it give me only 1 combination 46-47-48-49-50.

VBA Code: 
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 = 50                                                          ' <--- 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", "Euromillones")                             ' 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

Regards,
Moti
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
It is not easy to modify code prepared by somoene else :-) But I think I've managed.

The corrections are in 5 lines, clearly marked with 'EDIT comments in the code. Note that first is placed above first sub (Megamillions....

VBA Code: 
'EDIT - line added
Dim correction_value As Long

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
'
'EDIT - line added
correction_value = CLng(InputBox("What first number shall be used?", "Please decide")) - 1
    
    AmountOfNumbersChosen = 5                                                           ' <--- Set this to the AmountOfNumbersChosen
'EDIT - line changed
       MaxAmountOfNumbers = 50 - correction_value                                                        ' <--- 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", "Euromillones")                             ' 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
'EDIT - line changed
        lOutput(1, i) = i + correction_value
    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
'
'EDIT - line changed
            If lOutput(i, j) <= lNumber + correction_value - (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
 
Upvote 1
Solution
Kaper said:
It is not easy to modify code prepared by somoene else :) But I think I've managed.

The corrections are in 5 lines, clearly marked with 'EDIT comments in the code. Note that first is placed above first sub (Megamillions....
Click to expand...
Kaper, i am agree with you, I am grateful to you for modifying as I request and giving an option to choose the first starting number via input superb! 👌

I am sorry for not clarifying my request correctly 🙏 I said (Does it is possible to modify so I can select 1st number of choice for example number “1” so it give me only all combination with number “1”. If 2 then with 3 if 3 then with 3 if I select 46 then it give me only 1 combination 46-47-48-49-50.) .

But I would have make clear if I select 1st number of choice for example number “1” than it give me combination of only for with number “1”. Of if I select 1st number of choice for example number “2” than it give me combination of only for with number “2”.

Kaper, it is annoying please could you help me with my altered request.

Good Luck!

Kind Regards,
Moti :)
 
Upvote 0
So you mean that if you want the combinations starting with 45 you get only:

45-46-47-48-49
45-46-47-48-50
45-46-47-49-50
45-46-48-49-50
45-47-48-49-50


but not:
46-47-48-49-50

If that's true only one more change is needed:

VBA Code: 
        For j = lNoChosen To 2 Step -1
not To 1
It means first position is never changed

and its equivalent to this first number and all combinations of 4 out of all numbers larger than this first one.
so for 1 it is 1 and combination of 4 numbers from 2...50
and so on.

Or I still not understand you?
 
Upvote 1
Kaper said:
So you mean that if you want the combinations starting with 45 you get only:

45-46-47-48-49
45-46-47-48-50
45-46-47-49-50
45-46-48-49-50
45-47-48-49-50


but not:
46-47-48-49-50

If that's true only one more change is needed:

VBA Code: 
       [B] For j = lNoChosen To 2 Step -1[/B]
not To 1
It means first position is never changed

and its equivalent to this first number and all combinations of 4 out of all numbers larger than this first one.
so for 1 it is 1 and combination of 4 numbers from 2...50
and so on.

Or I still not understand you?
Click to expand...
Hello Kaper, thank you for looking into it and modifying.

Yes you got correct my viewpoint as you shown examples of number 45 there must be 5 combinations but after I modified and run it give me 6 one repeated 1st one below the 5th combinations.

Also if I run with number “1” it generate 2 million + when it should generate with one 211876 what I notice it generate 1st 1-2-3-4-5 last 1-47-48-49-50…these are 211876 it is ok…but it repeats 10 time with nº1 and generate 2118760 is it with me what I am doing wrong I cannot figure out need your guidance.

Good Luck!

Kind Regards,
Moti
 
Upvote 0
Kaper said:
It is not easy to modify code prepared by someone else :)
Click to expand...
Ha ha! I'm one of the someone else's :)

Try:

VBA Code: 
Sub Test()

    Dim MyNo As Long, MyMin As Long, MyMax As Long, MyCombinations() As Long
    
    MyMin = 44  'Change as appropriate, e.g. MyMin = 1 will give the required 211,876 results
    MyMax = 50
    MyNo = 5
    
    MyCombinations = GetCombinations(MyMin + 1, MyMax, MyNo - 1)
    
    On Error Resume Next
    Range("MyResults").ClearContents
    On Error GoTo 0
    
    With Range("A1").Resize(UBound(MyCombinations), MyNo)
        .Name = "MyResults"
        .Columns(1).Value = MyMin
        .Resize(, MyNo - 1).Offset(, 1).Value = MyCombinations
    End With

End Sub

Function GetCombinations(lMin As Long, lMax 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(lMax - lMin + 1, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
  
    For i = 1 To lNoChosen
        lOutput(1, i) = i + lMin - 1
    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) <= lMax - (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
ABCDE
14445464748
24445464749
34445464750
44445464849
54445464850
64445464950
74445474849
84445474850
94445474950
104445484950
114446474849
124446474850
134446474950
144446484950
154447484950
Sheet1
 
Upvote 2
StephenCrump said:
Ha ha! I'm one of the someone else's :)

Try:

VBA Code: 
Sub Test()

    Dim MyNo As Long, MyMin As Long, MyMax As Long, MyCombinations() As Long
   
    MyMin = 44  'Change as appropriate, e.g. MyMin = 1 will give the required 211,876 results
    MyMax = 50
    MyNo = 5
   
    MyCombinations = GetCombinations(MyMin + 1, MyMax, MyNo - 1)
   
    On Error Resume Next
    Range("MyResults").ClearContents
    On Error GoTo 0
   
    With Range("A1").Resize(UBound(MyCombinations), MyNo)
        .Name = "MyResults"
        .Columns(1).Value = MyMin
        .Resize(, MyNo - 1).Offset(, 1).Value = MyCombinations
    End With

End Sub

Function GetCombinations(lMin As Long, lMax 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(lMax - lMin + 1, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
 
    For i = 1 To lNoChosen
        lOutput(1, i) = i + lMin - 1
    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) <= lMax - (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
ABCDE
14445464748
24445464749
34445464750
44445464849
54445464850
64445464950
74445474849
84445474850
94445474950
104445484950
114446474849
124446474850
134446474950
144446484950
154447484950
Sheet1
Click to expand...
StephenCrump, thank you, yes this fulfils my altered request as I wanted and I like additional improvement that the combinations are generated in separate columns. 👌

Have a good start of the week ahead! Good Luck!

Kind Regards,
Moti :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
modify a macro by a bit?
Replies
7
Views
587
excelNewbie22
E
E
  • Solved
How to read data from another sheet and ignore blanks?
Replies
1
Views
622
excelNewbie22
E

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top