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

 

[S.H.A.D.O.]

Hi Everyone,

Thanks Jay & Bob for the Excellent Code you Posted.
I am New to VBA but have Managed to Adapt the Code so that if you Enter the Minimum Total that you want in Cell "A1" of "Sheet1", and the Maximum Total that you want in Cell "A2" of "Sheet1", then you can just Run the Program and it will Produce a Seperate Sheet for EACH Total in Accordance to the Minimum & Maximum Totals that you Specified.
If you Only want a Single Total, 134 for Example, Enter 134 in Cell "A1" AND "A2" of "Sheet1".
The Only thing is, that if you put 21 in Cell "A1" & 40 in Cell "A2" there is an ERROR saying, "Cannot rename a sheet to the same name as another sheet".

Option Explicit

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

Sub MultipleLottoSums()

    Dim nMin As Integer, _
        nMax As Integer

    Dim i As Long
    
    Dim Wks As Worksheet

    nMin = Sheets("Sheet1").Range("A1")
    nMax = Sheets("Sheet1").Range("A2")

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

Hope this Helps.
All the Best.
SHADO

 

[jindon]

Hi
try

Hi jindon

The code seems not providing the result rows by rows

OOps!
shoud be like this

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
                    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
                    Exit For
                End If
Next vi, v, iv, iii, ii, i
Cells(1, t).Resize(n).Value = b
End Sub

 

[Emily]

jindon

Thanks

 

[EJ42955]

Hi Everyone,

Thanks Jay & Bob for the Excellent Code you Posted.
I am New to VBA but have Managed to Adapt the Code so that if you Enter the Minimum Total that you want in Cell "A1" of "Sheet1", and the Maximum Total that you want in Cell "A2" of "Sheet1", then you can just Run the Program and it will Produce a Seperate Sheet for EACH Total in Accordance to the Minimum & Maximum Totals that you Specified.
If you Only want a Single Total, 134 for Example, Enter 134 in Cell "A1" AND "A2" of "Sheet1".
The Only thing is, that if you put 21 in Cell "A1" & 40 in Cell "A2" there is an ERROR saying, "Cannot rename a sheet to the same name as another sheet".

Option Explicit

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

Sub MultipleLottoSums()

    Dim nMin As Integer, _
        nMax As Integer

    Dim i As Long
    
    Dim Wks As Worksheet

    nMin = Sheets("Sheet1").Range("A1")
    nMax = Sheets("Sheet1").Range("A2")

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

Hope this Helps.
All the Best.
SHADO

Nice work, SHADO. Want to try tweaking this a little more?
Results show 5 numbers, instead of 6. (I know this isn't so tough.)
But, only show results if no 3 numbers are consecutive.
i.e If the results were to be- 1,2,3,44,45 = 1,2,3 are consecutive, don't add to list.
1,10,11,12,45 = 10,11,12 are consecutive, don't add to list
You get the idea.