Generate 5/50 lotteries with selected odd even pattern combinations

M

motilulla

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

I come across vba coded by Ruddles under the link below:
http://www.mrexcel.com/forum/excel-questions/539512-lottery-combinations-2.html#post2666862
And modified to work with 5/50 lottery it works perfect generate 2.118.760 all combinations in to 33 sheets.
As shown below
Code: 
 Option Explicit
 
Public Sub Generate6ex49()
 
Const MainSheet As String = "Sheet1"
Const SheetPrefix As String = "Part"
Const SplitPoint As Long = 65000
Const HighBall As Integer = 50
 
Dim iPtr As Integer
Dim sFileName As String
Dim SheetNumber As Integer
Dim iRow As Long
Dim iRec As Long
Dim iLastRow As Long
Dim ws As Worksheet
Dim sMessage As String
Dim sTime As Date
 
Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim p4 As Integer
Dim p5 As Integer
Dim p6 As Integer
 
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, Len(SheetPrefix)) = SheetPrefix Then
  Application.DisplayAlerts = False
  On Error Resume Next
  ws.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
End If
Next ws
 
Sheets(MainSheet).Columns("A:B").ClearContents
 
sMessage = vbCrLf & "Workbook reset. Proceed to create combination records?" _
       & Space(10) & vbCrLf & vbCrLf _
       & "Warning: this will take several minutes!"
If MsgBox(sMessage, vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
 
Sheets(MainSheet).Range("A1:B1").Font.Bold = True
Sheets(MainSheet).Range("A1") = "Worksheet"
Sheets(MainSheet).Range("B1") = "Records"
 
sTime = Now()
SheetNumber = 0
iRow = SplitPoint
iRec = 0
 
For p1 = 1 To HighBall - 4
For p2 = p1 + 1 To HighBall - 3
  For p3 = p2 + 1 To HighBall - 2
    For p4 = p3 + 1 To HighBall - 1
      'For p5 = p4 + 1 To HighBall - 1
        For p5 = p4 + 1 To HighBall
          iRec = iRec + 1
          iRow = iRow + 1
          If iRow > SplitPoint Then
            If SheetNumber > 0 Then
              iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
              Sheets(MainSheet).Cells(iLastRow, 2) = iRow - 1
            End If
            SheetNumber = SheetNumber + 1
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = SheetPrefix & Right("00" & CStr(SheetNumber), 3)
            Sheets(MainSheet).Activate
            iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
            Set ws = Sheets(SheetPrefix & Right("00" & CStr(SheetNumber), 3))
            Sheets(MainSheet).Cells(iLastRow + 1, 1) = ws.Name
            iRow = 1
          End If
          ws.Cells(iRow, 1) = p1
          ws.Cells(iRow, 2) = p2
          ws.Cells(iRow, 3) = p3
          ws.Cells(iRow, 4) = p4
          ws.Cells(iRow, 5) = p5
          'ws.Cells(iRow, 6) = p6
          DoEvents
        'Next p6
      Next p5
    Next p4
  Next p3
Next p2
Next p1
 
Sheets(MainSheet).Cells(iLastRow + 1, 2) = iRow
Sheets(MainSheet).Cells(iLastRow + 2, 1) = "Total"
Sheets(MainSheet).Cells(iLastRow + 2, 2) = iRec
Sheets(MainSheet).Columns("A:B").EntireColumn.AutoFit
Sheets(MainSheet).Range("A1").Select
 
MsgBox vbCrLf & Format(iRec, "#,###") & " records created" & Space(10) & vbCrLf & vbCrLf _
   & CStr(SheetNumber) & " worksheets created" & vbCrLf & vbCrLf _
   & "Run time: " & Format(Now() - sTime, "hh:nn:ss"), vbOKOnly + vbInformation
 
End Sub

I am looking please if some one can modify an existing code or make a new VBA for lottery 5/50 which has total 2.118.760 combinations I do not need VBA that generate all combinations only with the required odd even pattern I have no idea who much will be get with each pattern?
For Example:
ODD-EVEN
0-5
1-4
2-3
3-2
4-1
5-0

I mean VBA give input option For Odd & Even and generate all possible combination for that selected pattern
For example if input is 2-odd & 3-even numbers VBA generate following set of combination as shown


Book1
ABCDE
1n1n2n3n4n5
21629323641
3226274049
Odd Even


Thanks In Advance

Using Excel 2000

Regards,
Moti
 
Last edited:

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
Hallo motilulla, give this a try. I made little changes to the posted code.

Code: 
 Option Explicit
 
Public Sub Generate6ex49()
 
Const MainSheet As String = "Sheet1"
Const SheetPrefix As String = "Part"
Dim SplitPoint As Long '= 65000
SplitPoint = ActiveSheet.Rows.Count
Const HighBall As Integer = 50
 
Dim iPtr As Integer
Dim sFileName As String
Dim SheetNumber As Integer
Dim iRow As Long
Dim iRec As Long
Dim iLastRow As Long
Dim ws As Worksheet
Dim sMessage As String
Dim sTime As Date
Dim oeMessage As String
Dim Odds As Long

Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim p4 As Integer
Dim p5 As Integer
Dim p6 As Integer
 
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, Len(SheetPrefix)) = SheetPrefix Then
  Application.DisplayAlerts = False
  On Error Resume Next
  ws.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
End If
Next ws
 
Sheets(MainSheet).Columns("A:B").ClearContents
 
oeMessage = vbCrLf & "How many odds?"
Odds = CLng(InputBox(oeMessage))
If MsgBox("Proceed to create " & Odds & " Odds and " & (5 - Odds) & " Even combinations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

sMessage = vbCrLf & "Workbook reset. Proceed to create combination records?" _
       & Space(10) & vbCrLf & vbCrLf _
       & "Warning: this will take several minutes!"
If MsgBox(sMessage, vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
 
Sheets(MainSheet).Range("A1:B1").Font.Bold = True
Sheets(MainSheet).Range("A1") = "Worksheet"
Sheets(MainSheet).Range("B1") = "Records"
 
sTime = Now()
SheetNumber = 0
iRow = SplitPoint
iRec = 0
 
For p1 = 1 To HighBall - 4
For p2 = p1 + 1 To HighBall - 3
  For p3 = p2 + 1 To HighBall - 2
    For p4 = p3 + 1 To HighBall - 1
      'For p5 = p4 + 1 To HighBall - 1
        For p5 = p4 + 1 To HighBall
        If IIf((p1 Mod 2), 1, 0) + IIf((p2 Mod 2), 1, 0) + IIf((p3 Mod 2), 1, 0) + IIf((p4 Mod 2), 1, 0) + IIf((p5 Mod 2), 1, 0) = Odds Then
          iRec = iRec + 1
          iRow = iRow + 1
          If iRow > SplitPoint Then
            If SheetNumber > 0 Then
              iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
              Sheets(MainSheet).Cells(iLastRow, 2) = iRow - 1
            End If
            SheetNumber = SheetNumber + 1
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = SheetPrefix & Right("00" & CStr(SheetNumber), 3)
            Sheets(MainSheet).Activate
            iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
            Set ws = Sheets(SheetPrefix & Right("00" & CStr(SheetNumber), 3))
            Sheets(MainSheet).Cells(iLastRow + 1, 1) = ws.Name
            iRow = 1
          End If
          ws.Cells(iRow, 1) = p1
          ws.Cells(iRow, 2) = p2
          ws.Cells(iRow, 3) = p3
          ws.Cells(iRow, 4) = p4
          ws.Cells(iRow, 5) = p5
          'ws.Cells(iRow, 6) = p6
          End If
          DoEvents
        'Next p6
      Next p5
    Next p4
  Next p3
Next p2
Next p1
 
Sheets(MainSheet).Cells(iLastRow + 1, 2) = iRow
Sheets(MainSheet).Cells(iLastRow + 2, 1) = "Total"
Sheets(MainSheet).Cells(iLastRow + 2, 2) = iRec
Sheets(MainSheet).Columns("A:B").EntireColumn.AutoFit
Sheets(MainSheet).Range("A1").Select
 
MsgBox vbCrLf & Format(iRec, "#,###") & " records created" & Space(10) & vbCrLf & vbCrLf _
   & CStr(SheetNumber) & " worksheets created" & vbCrLf & vbCrLf _
   & "Run time: " & Format(Now() - sTime, "hh:nn:ss"), vbOKOnly + vbInformation
 
End Sub

Hope this helps
 
Upvote 0
B___P said:
Hallo motilulla, give this a try. I made little changes to the posted code.

Code: 
 Option Explicit
 
Public Sub Generate6ex49()
 
Const MainSheet As String = "Sheet1"
Const SheetPrefix As String = "Part"
Dim SplitPoint As Long '= 65000
SplitPoint = ActiveSheet.Rows.Count
Const HighBall As Integer = 50
 
Dim iPtr As Integer
Dim sFileName As String
Dim SheetNumber As Integer
Dim iRow As Long
Dim iRec As Long
Dim iLastRow As Long
Dim ws As Worksheet
Dim sMessage As String
Dim sTime As Date
Dim oeMessage As String
Dim Odds As Long

Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim p4 As Integer
Dim p5 As Integer
Dim p6 As Integer
 
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, Len(SheetPrefix)) = SheetPrefix Then
  Application.DisplayAlerts = False
  On Error Resume Next
  ws.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
End If
Next ws
 
Sheets(MainSheet).Columns("A:B").ClearContents
 
oeMessage = vbCrLf & "How many odds?"
Odds = CLng(InputBox(oeMessage))
If MsgBox("Proceed to create " & Odds & " Odds and " & (5 - Odds) & " Even combinations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

sMessage = vbCrLf & "Workbook reset. Proceed to create combination records?" _
       & Space(10) & vbCrLf & vbCrLf _
       & "Warning: this will take several minutes!"
If MsgBox(sMessage, vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
 
Sheets(MainSheet).Range("A1:B1").Font.Bold = True
Sheets(MainSheet).Range("A1") = "Worksheet"
Sheets(MainSheet).Range("B1") = "Records"
 
sTime = Now()
SheetNumber = 0
iRow = SplitPoint
iRec = 0
 
For p1 = 1 To HighBall - 4
For p2 = p1 + 1 To HighBall - 3
  For p3 = p2 + 1 To HighBall - 2
    For p4 = p3 + 1 To HighBall - 1
      'For p5 = p4 + 1 To HighBall - 1
        For p5 = p4 + 1 To HighBall
        If IIf((p1 Mod 2), 1, 0) + IIf((p2 Mod 2), 1, 0) + IIf((p3 Mod 2), 1, 0) + IIf((p4 Mod 2), 1, 0) + IIf((p5 Mod 2), 1, 0) = Odds Then
          iRec = iRec + 1
          iRow = iRow + 1
          If iRow > SplitPoint Then
            If SheetNumber > 0 Then
              iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
              Sheets(MainSheet).Cells(iLastRow, 2) = iRow - 1
            End If
            SheetNumber = SheetNumber + 1
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = SheetPrefix & Right("00" & CStr(SheetNumber), 3)
            Sheets(MainSheet).Activate
            iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
            Set ws = Sheets(SheetPrefix & Right("00" & CStr(SheetNumber), 3))
            Sheets(MainSheet).Cells(iLastRow + 1, 1) = ws.Name
            iRow = 1
          End If
          ws.Cells(iRow, 1) = p1
          ws.Cells(iRow, 2) = p2
          ws.Cells(iRow, 3) = p3
          ws.Cells(iRow, 4) = p4
          ws.Cells(iRow, 5) = p5
          'ws.Cells(iRow, 6) = p6
          End If
          DoEvents
        'Next p6
      Next p5
    Next p4
  Next p3
Next p2
Next p1
 
Sheets(MainSheet).Cells(iLastRow + 1, 2) = iRow
Sheets(MainSheet).Cells(iLastRow + 2, 1) = "Total"
Sheets(MainSheet).Cells(iLastRow + 2, 2) = iRec
Sheets(MainSheet).Columns("A:B").EntireColumn.AutoFit
Sheets(MainSheet).Range("A1").Select
 
MsgBox vbCrLf & Format(iRec, "#,###") & " records created" & Space(10) & vbCrLf & vbCrLf _
   & CStr(SheetNumber) & " worksheets created" & vbCrLf & vbCrLf _
   & "Run time: " & Format(Now() - sTime, "hh:nn:ss"), vbOKOnly + vbInformation
 
End Sub

Hope this helps
Click to expand...
Outstanding, B___P thank you very much I just try with 2 ODD and it generates 690.000 combinations it is fast and sparkling.

It is exactly what I was after I can't thank you enough.

Have a great weekend

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

Similar threads

JenniferMurphy
  • Question
Recursion example
Replies
0
Views
562
JenniferMurphy
JenniferMurphy
K
  • Question
Make 7 combinations out of 5-pattern applying special conditions
2 3
Replies
22
Views
1K
Kishan
K
R
  • Question
double loop issue
Replies
4
Views
331
ronniebex
R
mercmannick
  • Question
select case help
Replies
7
Views
609
mercmannick
mercmannick

Forum statistics

Threads
1,215,787
Messages
6,126,900
Members
449,348
Latest member
Rdeane

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