Lotto combinations with a proviso

[lakelands]

Simple lotto question - we are trying to get 6 number combinations from 45 numbers but need to only select those where the sum of the six numbers is 134 - help appreciated

 

[Derek]

Hi there

Don't know an easy answer to do this, but this could give you a start. I hope you have plenty of patience as I suspect there are many combinations that fit your criteria.

On a blank worksheet, paste in these formulas:
in cell N1 formula is =CONCATENATE(TEXT(H1,"00"),TEXT(I1,"00"),TEXT(J1,"00"),TEXT(K1,"00"),TEXT(L1,"00"),TEXT(M1,"00"))
in cell O1 formula is =MAX(COUNTIF(H1:M1,H1),COUNTIF(H1:M1,I1),COUNTIF(H1:M1,J1),COUNTIF(H1:M1,K1),COUNTIF(H1:M1,L1),COUNTIF(H1:M1,M1))
In cell P1 formula is =COUNTIF(N2:N65536,N1)

Then run this macro code in a standard module:

Sub Combinations()
Application.ScreenUpdating = False
[a1].Value = 1
Do Until [a1].Value = 46
[b1].Value = 2
Do Until [b1].Value = 46
[c1].Value = 3
Do Until [c1].Value = 46
[d1].Value = 1
Do Until [d1].Value = 46
[e1].Value = 1
Do Until [e1].Value = 46
[f1].Value = 1
Do Until [f1].Value = 46
If WorksheetFunction.Sum(Range("A1:F1")) = 134 Then
Range("A1:F1").Copy Destination:=Range("H1")
Range("H1:M1").Sort Key1:=Range("H1"), Order1:=xlAscending, Orientation:=xlLeftToRight
If Range("O1").Value = 1 And Range("P1").Value = 0 Then Range("H1:N1").Copy Destination:=Range("H65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
[f1].Value = [f1].Value + 1
Loop
[e1].Value = [e1].Value + 1
Loop
[d1].Value = [d1].Value + 1
Loop
[c1].Value = [c1].Value + 1
Loop
[b1].Value = [b1].Value + 1
Loop
[a1].Value = [a1].Value + 1
Loop
MsgBox "Task Completed"
End Sub


The methodology here is to run the 6 number combinations in cells A1:F1 and when a combination sums to 134 the combination is pasted to cells H1:M1 and sorted into ascending order (left to right). This enables the formula in N1 to concatenated those cells into one as text (so as not to lose leading zeros) which then allows the formula in
P1 to check if the same combination has already been pasted to column M. The formula in cell O1 checks if any numbers in the combination are duplicates. Finally, when all numbers in the combination are unique, sum to 134 and do not already appear in column M, then that combination is added to the list in column M.

Probably some mathematical wiz out there has a really neat and clever way of doing. Anyhow this is the easy part......I am sure actually winning Lotto will prove much harder!
Good Luck
Derek

 

[Jay Petrulis]

Here is a brute force approach, but will run pretty quick. It can certainly be optimized further (plus take advantage of recursion to have all inputs as variables).

Option Explicit

Sub RunLottoSpecial()
    Call LottoSpecial(45, 134)
End Sub

Sub LottoSpecial(Num As Long, TargetVal As Long)
    
    Dim a As Integer, _
        b As Integer, _
        c As Integer, _
        d As Integer, _
        e As Integer, _
        f As Integer
    
    Dim Counter As Long, _
        NumCols As Long, _
        i As Long
    
    Dim arrResults
    
    Application.ScreenUpdating = False
    
    For a = 1 To Num - 5
        For b = a + 1 To Num - 4
            For c = b + 1 To Num - 3
                For d = c + 1 To Num - 2
                    For e = d + 1 To Num - 1
                        For f = e + 1 To Num
                            If a + b + c + d + e + f = TargetVal Then
                                Application.StatusBar = Counter
                                Counter = Counter + 1
                                With ActiveSheet
                                    If Counter Mod 65536 = 0 Then
                                        .Cells(65536, i + 1) = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                        i = i + 1
                                    Else
                                        .Cells(Counter Mod 65536, i + 1) = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                    End If
                                End With
                            End If
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

 

[Derek]

Good One Jay!

Derek

 

[lakelands]

Thanks all - now for some real mathematical back testing

 

[EJ42955]

Jay,
Love what you did for lakelands original request. I've been able to make changes for some parameters i wanted. But, one thing I'm not sure about accomplishing. Can you help?

Instead of the sum of the number string equalling 134, how hard would it be to get the results to be between 60 and 120?

Thanks,
E J

 

[Bob Rooney]

How about trying something like this? It will put each sum into a separate sheet (did not add any error checking to make sure the sheet does not exists before adding it).

Sub MultipleLottoSums()
Dim i As Long, Wks As Worksheet

With ThisWorkbook
    For i = 60 To 120
        Set Wks = .Worksheets.Add
        With Wks
            .Activate
            .Name = "Sum_to_" & i
            Call LottoSpecial(45, i)
        End With
    Next i
End With

End Sub

 

[scu77]

Let's make fast Jay's code and use Bob's code

I changed print out

Sub MultipleLottoSums()
  
  Dim i As Long
  
  On Error GoTo Er
  
  Make_TextFile
 
  Open ActiveWorkbook.Path & "Report.txt" For Output As #1


        For i = 60 To 120
                 
           Application.StatusBar = "Finding combination ....Total sum = " & i
           
                Call LottoSpecial(45, i)
            
        Next i
    
           Application.StatusBar = ""
           
        
        Close #1
           
        MsgBox "Check text file .... " & ActiveWorkbook.Path & "Report.txt"
        
 Exit Sub
 
Er:
 
 MsgBox "Error"
 
End Sub




Sub LottoSpecial(Num As Long, TargetVal As Long)
    
    Dim a As Integer, _
        b As Integer, _
        c As Integer, _
        d As Integer, _
        e As Integer, _
        f As Integer
    
    Dim Counter As Long, _
        NumCols As Long, _
        i As Long
    
    Dim arrResults
    Dim varTemp As String
    
    
    For a = 1 To Num - 5
        For b = a + 1 To Num - 4
            For c = b + 1 To Num - 3
                For d = c + 1 To Num - 2
                    For e = d + 1 To Num - 1
                        For f = e + 1 To Num
                            If a + b + c + d + e + f = TargetVal Then
                                                                             
                                       varTemp = a & "," & b & "," & c & "," & d & "," & e & "," & f
                               
                                       Write #1, varTemp
                                       
                                       varTemp = ""
                            End If
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a


End Sub


Sub Make_TextFile()

Open ActiveWorkbook.Path & "Report.txt" For Output As #1

Close #1

End Sub

 

[jindon]

Hi
try

Sub test()
Dim i As Integer, ii As Integer, iii As Integer, iv As Integer
Dim v As Integer, vi As Integer, n As Long, t As Integer, b()
t = 1 : n = 1
ReDim b(1 To Rows.Count, 1 To 1)
For i = 1 To 45 - 5
   For ii = i + 1 To 45 - 4
      For iii = ii + 1 To 45 - 3
         For iv = iii + 1 To 45 - 2
            For v = iv + 1 To 45 - 1
               For vi = v + 1 To 45
                  If i + ii + iii + iv + v + vi = 134 Then                       
                     b(n,1) = i & "," & ii & "," & iii & "," & iv & "," & v & "," vi
                  End If
                  n = n + 1
                  If n > Rows.Count Then
                     Cells(1,t).Resize(Rows.Count).Value = b
                     n = 1 : t = t + 1
                     Redim b(1 To Rows.Count, 1 To 1)
                  End If
Next vi, v, iv, iii, ii, i
Cells(1,t).Resize(n).Value = b
End Sub

 

[Emily]

Hi
try

Hi jindon

The code seems not providing the result rows by rows