VBA, lottery total combinations could be ended with sums (only sum list)

M

motilulla

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

I am looking for how many total combinations could be made with sums. For example lottery EuroMillions has 50 numbers out of that 5 numbers is drawn so far formula =COMBIN(50,5) there are 2.118.760 total combinations can be made.

Now say for example if starting number "1" is fixed I mean if played numbers with only so it will generate =COMBIN(49,4) = 211.876 combinations now these combinations have sum from 15 to 240.

I am looking answer how will be the distribution of 211.876 combinations with each sum (15 to 240) I just want VBA that can list total combination with each of the sum

Please see the example below for example with sum 15 only will be possibly 1 combination with sum 15 = 1,2,3,4,5 and need to find till sum 240 ( only sum list )

SumPlaying Fix Num=1
SumCombinations
15​
1
16​
17​
18​
19​
20​
21​
22​
23​
24​
25​
26​
27​
28​
29​
30​
31​
32​
33​
34​
35​
36​
37​
38​
39​
40​
41​
42​
43​
44​
45​
46​
47​
48​
49​
50​
51​
52​
53​
54​
55​
56​
57​
58​
59​
60​
61​
62​
63​
64​
65​
66​
67​
68​
69​
70​
71​
72​
73​
74​
75​
76​
77​
78​
79​
80​
81​
82​
83​
84​
85​
86​
87​
88​
89​
90​
91​
92​
93​
94​
95​
96​
97​
98​
99​
100​
101​
102​
103​
104​
105​
106​
107​
108​
109​
110​
111​
112​
113​
114​
115​
116​
117​
118​
119​
120​
121​
122​
123​
124​
125​
126​
127​
128​
129​
130​
131​
132​
133​
134​
135​
136​
137​
138​
139​
140​
141​
142​
143​
144​
145​
146​
147​
148​
149​
150​
151​
152​
153​
154​
155​
156​
157​
158​
159​
160​
161​
162​
163​
164​
165​
166​
167​
168​
169​
170​
171​
172​
173​
174​
175​
176​
177​
178​
179​
180​
181​
182​
183​
184​
185​
186​
187​
188​
189​
190​
191​
192​
193​
194​
195​
196​
197​
198​
199​
200​
201​
202​
203​
204​
205​
206​
207​
208​
209​
210​
211​
212​
213​
214​
215​
216​
217​
218​
219​
220​
221​
222​
223​
224​
225​
226​
227​
228​
229​
230​
231​
232​
233​
234​
235​
236​
237​
238​
239​
240​

Thank you all.

I am using Excel 2000

Regards,
Moti
 
Sort by date Sort by votes

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Marc L said:
And what should be the expected result if the list is fixing numbers 1 & 4 ?

Marc L, in this case fixing numbers "1 & 4" there would be left 48 numbers in the game, as the 2 & 3 will be excluded.

Out of the 48 fixing 2 there will be =COMBIN(46,3) =15.180 total combinations

Starting 1st set of 5 will be with min sum 1, 4, 5, 6, 7 = 23, and the last set of 5 will be with max sum 1, 4, 48, 49, 50 = 152 this is what I am thinking so...

Kind Regards
Moti
 
Upvote 0
Last but not least according to the previous post to paste to the top of the worksheet module :​
VBA Code: 
Const K = 5, U = 50
  Dim oDic As Object

Sub CountSumCombinate(L&, S&, P&, Optional N&)
    Dim A&
    For P = P To U - N
        A = S + P:  If L < K Then CountSumCombinate L + 1, A, P + 1 Else oDic(A) = oDic(A) + 1
    Next
End Sub

Sub Demo3()
    Dim C&, M$, S&, X
        [A1].CurrentRegion.Offset(1).Clear
    Do
        M = InputBox(vbLf & M & vbLf & vbLf & " Space delimited :", "Fix number(s)"):  If M = "" Then Exit Sub
        X = Split(Application.Trim(M)):  M = "":  S = 0
    For C = 0 To UBound(X)
        If X(C) < 1 Or X(C) > U Then M = " Number between 1 and " & U & " only !": Beep: Exit For
        S = S + X(C)
    Next
        If M = "" Then If X(UBound(X)) > U - K + 1 + UBound(X) Then M = " Last number too high !": Beep
    Loop Until M = ""
        Set oDic = CreateObject("Scripting.Dictionary")
        CountSumCombinate UBound(X) + 2, S, X(UBound(X)) + 1, K - UBound(X) - 2
    If oDic.Count Then
        [A2].Resize(oDic.Count, 2).Value2 = Application.Transpose(Array(oDic.Keys, oDic.Items))
        oDic.RemoveAll
    End If
        Set oDic = Nothing
End Sub
 
Upvote 0
Missing check - not fixing more than 4 numbers - added in Demo3 :​
VBA Code: 
Sub Demo3()
    Dim C&, M$, S&, X
        [A1].CurrentRegion.Offset(1).Clear
    Do
            M = InputBox(vbLf & M & vbLf & vbLf & " Space delimited :", "Fix number(s)"):  If M = "" Then Exit Sub
            X = Split(Application.Trim(M))
        If UBound(X) >= K - 1 Then
            M = " Maximum " & K - 1 & " numbers !":  Beep
        Else
            M = "":  S = 0
        For C = 0 To UBound(X)
            If X(C) < 1 Or X(C) > U Then M = " Number between 1 and " & U & " only !": Beep: Exit For
            S = S + X(C)
        Next
            If M = "" Then If X(UBound(X)) > U - K + 1 + UBound(X) Then M = " Last number too high !": Beep
        End If
    Loop Until M = ""
        Set oDic = CreateObject("Scripting.Dictionary")
        CountSumCombinate UBound(X) + 2, S, X(UBound(X)) + 1, K - UBound(X) - 2
    If oDic.Count Then
        [A2].Resize(oDic.Count, 2).Value2 = Application.Transpose(Array(oDic.Keys, oDic.Items))
        oDic.RemoveAll
    End If
        Set oDic = Nothing
End Sub
 
Upvote 0
Optimization for the Combinate procedure :​
VBA Code: 
Const K = 5, U = 50
  Dim oDic As Object

Sub CountSumCombinate(L&, S&, P&)
    Dim A&
    For P = P To U - K + L
        A = S + P:  If L < K Then CountSumCombinate L + 1, A, P + 1 Else oDic(A) = oDic(A) + 1
    Next
End Sub

Sub Demo3()
    Dim C&, M$, S&, X
        [A1].CurrentRegion.Offset(1).Clear
    Do
            M = InputBox(vbLf & M & vbLf & vbLf & " Space delimited :", "Fix number(s)"):  If M = "" Then Exit Sub
            X = Split(Application.Trim(M))
        If UBound(X) >= K - 1 Then
            M = " Maximum " & K - 1 & " numbers !":  Beep
        Else
            M = "":  S = 0
        For C = 0 To UBound(X)
            If X(C) < 1 Or X(C) > U Then M = " Number between 1 and " & U & " only !": Beep: Exit For
            S = S + X(C)
        Next
            If M = "" Then If X(UBound(X)) > U - K + 1 + UBound(X) Then M = " Last number too high !": Beep
        End If
    Loop Until M = ""
        Set oDic = CreateObject("Scripting.Dictionary")
        CountSumCombinate UBound(X) + 2, S, X(UBound(X)) + 1
    If oDic.Count Then
        [A2].Resize(oDic.Count, 2).Value2 = Application.Transpose(Array(oDic.Keys, oDic.Items))
        oDic.RemoveAll
    End If
        Set oDic = Nothing
End Sub
 
Upvote 0
Marc L said:
Optimization for the Combinate procedure :​
Click to expand...
Superb! Marc L, I did not asked neither I thought it can be possible to get sum results fixing multiple numbers, you did amazing job I like it very much. ?
I appreciate your kind help :)


Marc L said:
As it's better with the screen updating desactivated so finally :​
VBA Code: 
Const K = 5
  Dim N&, R&, V(), W

Sub SumCombinate(L&, S&, T$, Optional P&)
    Dim A&, C$
    For P = P To UBound(W) + N * (P = 0)
        A = S + W(P):  C = T & W(P)
        If L < K Then SumCombinate L + 1, A, C & " ", P + 1 Else R = R + 1: V(R, 0) = A: V(R, 1) = C
    Next
End Sub

Sub Demo1()
        Dim M$, S&, X
    Do
            M = InputBox(vbLf & M & vbLf & vbLf & "Space delimited :", "Fix number(s)"):  If M = "" Then Exit Sub
            X = Split(Application.Trim(M))
        If UBound(X) >= K - 1 Then
            M = "1 to " & K - 1 & " numbers only !":  Beep
        Else
                M = "":  S = 0:  W = [COLUMN(A:AX)]
            For R = 0 To UBound(X)
                If X(R) < 1 Or X(R) > 50 Then M = "Number(s) between 1 and 50 only !": Beep: Exit For
                S = S + X(R):  W(X(R)) = False
            Next
        End If
    Loop Until M = ""
        [A1].CurrentRegion.Offset(1).Clear
        ReDim V(1 To Application.Combin(50 - UBound(X) - 1, K - UBound(X) - 1), 1)
        N = K - UBound(X) - 2:  R = 0:  W = Filter(W, False, False)
        SumCombinate UBound(X) + 2, S, Join(X) & " "
    If R Then
            Application.ScreenUpdating = False
        With [A2].Resize(R, 2)
            .IndentLevel = 2
            .Columns(1).HorizontalAlignment = xlRight
            .Value2 = V
            .Sort .Cells(1), 1, Header:=2
        End With
            Application.ScreenUpdating = True
    End If
        Erase V, W
End Sub
Click to expand...
Marc L, May I ask you one more favour can you modify this post#14 macro (as per your last Post#26 VBA) so this also can generate combination only of the left numbers...

In this case fixing numbers "1 & 4" there would be left 48 numbers in the game, as the 2 & 3 will be excluded. Out of the 48 fixing 2 there will be =COMBIN(46,3) =15.180 total combinations

Starting 1st set of 5 will 1, 4, 5, 6, 7 and the last set of 5 will be 1, 4, 48, 49, 50

I love your idea generate all combinations with selected fix numbers of sums great idea

Please can you help?

Kind Regards
Moti
 
Upvote 0
Replace all the worksheet module with this code containing both ways :​
VBA Code: 
Const K = 5, U = 50
  Dim oDic As Object, R&, V()

Sub CountSumCombinate(L&, S&, P&)
    Dim A&
    For P = P To U - K + L
        A = S + P:  If L < K Then CountSumCombinate L + 1, A, P + 1 Else oDic(A) = oDic(A) + 1
    Next
End Sub

Sub SumCombinate(L&, S&, P&, T$)
    Dim A&, C$
    For P = P To U - K + L
        A = S + P:   C = T & P
        If L < K Then SumCombinate L + 1, A, P + 1, C & " " Else R = R + 1: V(R, 0) = A: V(R, 1) = C
    Next
End Sub

Sub Combinate(Optional Generate As Boolean)
        Dim M$, S&, X
        [A1].CurrentRegion.Offset(1).Clear
    Do
            M = InputBox(vbLf & M & vbLf & vbLf & " Space delimited :", "Fix number(s)"):  If M = "" Then Exit Sub
            X = Split(Application.Trim(M))
        If UBound(X) >= K - 1 Then
            M = " Maximum " & K - 1 & " numbers !":  Beep
        Else
            M = "":  S = 0
        For R = 0 To UBound(X)
            If X(R) < 1 Or X(R) > U Then M = " Number between 1 and " & U & " only !": Beep: Exit For
            S = S + X(R)
        Next
            If M = "" Then If X(UBound(X)) > U - K + 1 + UBound(X) Then M = " Last number too high !": Beep
        End If
    Loop Until M = ""
    If Generate Then
            ReDim V(1 To Application.Combin(U - X(UBound(X)), K - UBound(X) - 1), 1)
            R = 0
            SumCombinate UBound(X) + 2, S, X(UBound(X)) + 1, Join(X) & " "
        If R Then
                 Application.ScreenUpdating = False
            With [A2].Resize(R, 2)
                .IndentLevel = 2
                .Columns(1).HorizontalAlignment = xlRight
                .Value2 = V
                .Sort .Cells(1), 1, Header:=2
            End With
                 Application.ScreenUpdating = True
        End If
            Erase V
    Else
            Set oDic = CreateObject("Scripting.Dictionary")
            CountSumCombinate UBound(X) + 2, S, X(UBound(X)) + 1
        If oDic.Count Then
            [A2].Resize(oDic.Count, 2).Value2 = Application.Transpose(Array(oDic.Keys, oDic.Items))
            oDic.RemoveAll
        End If
            Set oDic = Nothing
    End If
End Sub

Sub CountCombinationsBySum()
    Combinate
End Sub

Sub ListCombinationsBySum()
    Combinate True
End Sub
 
Last edited:
Upvote 0
Solution
Marc L said:
Replace all the worksheet module with this code containing both ways :​
VBA Code: 
Const K = 5, U = 50
  Dim oDic As Object, R&, V()

Sub CountSumCombinate(L&, S&, P&)
    Dim A&
    For P = P To U - K + L
        A = S + P:  If L < K Then CountSumCombinate L + 1, A, P + 1 Else oDic(A) = oDic(A) + 1
    Next
End Sub

Sub SumCombinate(L&, S&, P&, T$)
    Dim A&, C$
    For P = P To U - K + L
        A = S + P:   C = T & P
        If L < K Then SumCombinate L + 1, A, P + 1, C & " " Else R = R + 1: V(R, 0) = A: V(R, 1) = C
    Next
End Sub

Sub Combinate(Optional Generate As Boolean)
        Dim M$, S&, X
        [A1].CurrentRegion.Offset(1).Clear
    Do
            M = InputBox(vbLf & M & vbLf & vbLf & " Space delimited :", "Fix number(s)"):  If M = "" Then Exit Sub
            X = Split(Application.Trim(M))
        If UBound(X) >= K - 1 Then
            M = " Maximum " & K - 1 & " numbers !":  Beep
        Else
            M = "":  S = 0
        For R = 0 To UBound(X)
            If X(R) < 1 Or X(R) > U Then M = " Number between 1 and " & U & " only !": Beep: Exit For
            S = S + X(R)
        Next
            If M = "" Then If X(UBound(X)) > U - K + 1 + UBound(X) Then M = " Last number too high !": Beep
        End If
    Loop Until M = ""
    If Generate Then
            ReDim V(1 To Application.Combin(U - X(UBound(X)), K - UBound(X) - 1), 1)
            R = 0
            SumCombinate UBound(X) + 2, S, X(UBound(X)) + 1, Join(X) & " "
        If R Then
                 Application.ScreenUpdating = False
            With [A2].Resize(R, 2)
                .IndentLevel = 2
                .Columns(1).HorizontalAlignment = xlRight
                .Value2 = V
                .Sort .Cells(1), 1, Header:=2
            End With
                 Application.ScreenUpdating = True
        End If
            Erase V
    Else
            Set oDic = CreateObject("Scripting.Dictionary")
            CountSumCombinate UBound(X) + 2, S, X(UBound(X)) + 1
        If oDic.Count Then
            [A2].Resize(oDic.Count, 2).Value2 = Application.Transpose(Array(oDic.Keys, oDic.Items))
            oDic.RemoveAll
        End If
            Set oDic = Nothing
    End If
End Sub

Sub CountCombinationsBySum()
    Combinate
End Sub

Sub ListCombinationsBySum()
    Combinate True
End Sub
Click to expand...
Marc L, I am wonder to see the Count/List combinations by sum 2 in 1 VBA solution added with multiple fix numbers you have done far beyond what I ask in the opening Post#1 felling very happy.

I am so grateful to you for giving a best response and time you spent to solve it far better. ?

I wish you Good Luck.

Kind Regards
Moti :)
 
Upvote 0
​
Thanks. The logic used is exactly the same as in joeu2004 post #4, just revamped to a 'single loop' sub procedure like in your previous thread …​
​
The Dictionary way works only under Windows, can be avoided just using an array like joeu2004 did.​
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Weighted lottery help?
2
Replies
14
Views
4K
bebo021999
B
N
  • Solved
Sum total between bottle refill times
Replies
5
Views
556
Georgiboy
Georgiboy
S
  • Solved
VBA: All combinations that sum between two numbers - too much processing blows up
Replies
4
Views
1K
solutelan
S
M
  • Solved
VBA generate 5_50 combinations from (column A) list.
Replies
3
Views
395
StephenCrump
S
P
  • Solved
Calculate based on date sum of hours based on date
2
Replies
15
Views
775
psycoperl
P

Forum statistics

Threads
1,224,828
Messages
6,181,204
Members
453,022
Latest member
RobertV1609

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