Looking for Helps

M

michael168

Member
Hi! VBA Expert,

I am looking for some VBA help in updating 2 columns based on the pick 6 lottery.

In an Excel worksheet, I have 8 columns as below:

Col A = Draw
Col B = Date
Col C : Col H = Draw Nos (Ball 1 to Ball 6)

I wish to update Col I & Col J for the final digits and the ten digits.

An example :

Ball 1 to Ball 6 (11,12,16,21,34,39)

For the final digits

Col I = 2-1-1-1-1 since the final digts of 11 & 21 are euqal to 1.

For the ten digits

Col J = 3-2-1 since 11,12,16 are 1 group, 21 another group, and 34,39 another group.

I wish there are someone who can help me this VBA module. When I run the module,it will update Col I & Col J if Col I & Col J are empty and Col C : Col H are filled with Draw Nos.

Thanks
Michael
 
S

sss

Member
michael168 said:
I wish to update Col I & Col J for the final digits and the ten digits.

An example :

Ball 1 to Ball 6 (11,12,16,21,34,39)

For the final digits

Col I = 2-1-1-1-1 since the final digts of 11 & 21 are euqal to 1.

For the ten digits

Col J = 3-2-1 since 11,12,16 are 1 group, 21 another group, and 34,39 another group.

I wish there are someone who can help me this VBA module. When I run the module,it will update Col I & Col J if Col I & Col J are empty and Col C : Col H are filled with Draw Nos.

Thanks
Michael [/B]
Click to expand...

Hi Michael,
Copy and paste into module, and then run macro1
============== begin ================
Const TenDigitsColumn = 9 'column "I"
Const FinalDigitsColumn = 10 'column "J"
Const FirstNumberColumn = 3 'column "C"

Sub macro1()
Dim TotalRows&
Dim i&, j&
Dim OK As Boolean
'Rows in a sheet
TotalRows = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).row

For i = 1 To TotalRows
OK = Trim(Cells(i, TenDigitsColumn)) = "" And Trim(Cells(i, FinalDigitsColumn)) = "" 'columns I & J are empty
If OK Then
'check if any of 6 numbers is empty
'additional validation may include check if isnumeric() etc...
For j = 1 To 6
If Trim(Cells(i, FirstNumberColumn + j - 1)) = "" Then 'column is empty
OK = False
Exit For
End If
Next
End If

If OK Then
Cells(i, TenDigitsColumn) = "'" & GetTenDigits(i)
Cells(i, FinalDigitsColumn) = "'" & GetFinalDigits(i)
End If
Next
MsgBox "Done!"
End Sub

Private Function GetTenDigits(ByVal row&)
Dim A(0 To 4) As Integer 'for Decades 0 through 4
Dim i As Integer
Dim v As Integer
Dim s$
For i = 1 To 6
v = Cells(row, FirstNumberColumn + i - 1)
A(v \ 10) = A(v \ 10) + 1
Next
s = ""
For i = 0 To 4
If A(i) <> 0 Then s = s & A(i) & "-"
Next

GetTenDigits = Left(s, Len(s) - 1)
End Function

Private Function GetFinalDigits(ByVal row&)
Dim A(0 To 9) As Integer 'for digits 0 .. 9
Dim i As Integer
Dim v As Integer
Dim s$
For i = 1 To 6
v = Cells(row, FirstNumberColumn + i - 1)
A(v Mod 10) = A(v Mod 10) + 1
Next
s = ""
For i = 0 To 9
If A(i) <> 0 Then s = s & A(i) & "-"
Next
GetFinalDigits = Left(s, Len(s) - 1)
End Function

============== end =================

sss
 
P

PAB

Member
Hi sss,

What a nice Macro.
I was trying to do something with Custom Grids in another Thread ( Questions & Answers and Thread "to maggie" ). Would it be possible for you to have a quick look at it and tell me if this is achievable using VB :confused: .

Thanks Very Much
All the Best
PAB
:wavey:
 
S

sss

Member
PAB said:
Hi sss,

What a nice Macro.
I was trying to do something with Custom Grids in another Thread ( Questions & Answers and Thread "to maggie" ). Would it be possible for you to have a quick look at it and tell me if this is achievable using VB :confused: .

Thanks Very Much
All the Best
PAB
:wavey:
Click to expand...

Hi PAB,

I went through the "To Maggie" thread and found out what
you discussed there is very much like what I tried to implement before I switched to Keno ( now it is is my favorite game :) )
I still use that old program for Ontario 649. It is actually a filter, or custom grid or whatever. Looks ugly, no help, not very intuitive,
uses Access database to keep draws (plain text file would be much better) etc... cause I wrote it for myself. Later on if I have time I may probably work on it to make it more friendly:confused:
However it's extrimely fast! So if you want I can send it to you.
What I intended do build was a tool which not only allowed you
to filter combinations based on various criteria, but what is more
important, it should've automatically set the best values for all criteria. This hasn't been done though, all criteria values should be set up manually. Program provides some stats info based on a draws history that may be helpful in making a decision what value for a given criterion to choose.
If you want to build your own tool discussed earlier, I can not
see any reason why it's not achievable with VB or VBA. The
other thing is it could turn to be rather tedious.
sss
 
P

PAB

Member
Thanks sss for your reply.
What I basically want is for each Combination that is produced, check to see if MORE than 4 of the Numbers out of the 6 are included in ANY of the groups. If they are, IGNORE them.
The Custom Grid can change so it would be nice if the Groups are Hard Coded into the Program so that they can be changed to whatever. Also if the Criteria changes ( maybe have only 3 Numbers in ANY one Group ) to be able to change it in the Actual Code.
Thank you very much for looking at this.

All the Best
PAB
:wavey:
 
P

PAB

Member
Hi sss,

Is it not possible to amend the Macro by Defining the Different Groups?, then get the Macro to IGNORE Combinations that have MORE than 4 Numbers out of the 6 from ANY ONE Group. It would be nice to be able to do this.

All the Best
PAB
:wavey:
 
S

sss

Member
PAB said:
Hi sss,

Is it not possible to amend the Macro by Defining the Different Groups?, then get the Macro to IGNORE Combinations that have MORE than 4 Numbers out of the 6 from ANY ONE Group. It would be nice to be able to do this.

All the Best
PAB
:wavey:
Click to expand...

Hi PAB,

Private Function getGroups(A As Variant) As Integer
'input array is a an array(1 to 6) - this is a combination to be tested

'Array ColumnCount is a (1 to 5) array, each of its 5 items
'will represent number of occurances in corresponding column
'of your criteria grid
Dim ColumnCount(1 To 5) As Integer

Dim i&, Column&, ColumnsOccupied&

'initializing:
ColumnsOccupied = 0
For i = 1 To 5
ColumnCount(i) = 0
Next

For i = 1 To 6 'check all items of the input array: what column of a grid do they belong to:
Select Case A(i)
Case 1, 6, 11, 16, 21, 26, 31, 36, 41, 46: Column = 1
Case 2, 7, 12, 17, 22, 27, 32, 37, 42, 47: Column = 2
Case 3, 8, 13, 18, 23, 28, 33, 38, 43, 48: Column = 3
Case 4, 9, 14, 19, 24, 29, 34, 39, 44, 49: Column = 4
Case 5, 10, 15, 20, 25, 30, 35, 40, 45: Column = 5
End Select
ColumnCount(Column) = ColumnCount(Column) + 1
Next

For i = 1 To 5
A(i) = ColumnCount(i)
If A(i) <> 0 Then ColumnsOccupied = ColumnsOccupied + 1
Next

getGroups = ColumnsOccupied

'This function returns total number of columns occupied by a set
'that has been passed to function
'Also, it returns back an array of number of column occurances,
'e.g if a combination is 1,2,3,4,5,6
'and a test array Test(1)=1, Test(2)=2,...Test(6)=6, then
' HowManyColumns=getGroups(Test) call will result in
' 1. HowManyColumns variable will be equal to 5 (all 5 columns are occupied)
' 2. Array: Test(1)=2 (numbers 1 & 6 belong to the same column#1)
' Test(2)=1 (just ONE number, which is a "2" number belongs to the column #2)
' Test(3)=1
' Test(4)=1
' Test(5)=1
' Test(6)= Not Changed. Should be ignored, as we don't have Column #6
' If however, you change your criteria, and redesigne your grid to have
' 7 columns 7 number each, you have to change dimension of a input array.
' Test array has to have (1 to 7) size in that case. Even though your source
'combination has 6 number, you have to pass 7 values in order to be able to
'get back 7 values.
End Function

1. Define array like dim A(1 to 6) as integer
2.Start from the first line of your spreadsheet and go through
all draws that you have in it.
for i=1 to LastDraw'LastDraw ia a variable with the last draw number which you know for sure
...
next

3. Put code instead "...". This code will:
- assign array values to a draw numbers, like for i=1 to 6: A(i)=Cells(currentRow,currentCol+i)
-call GetGroups function and make a desision based on business rules you like.
ColumnsOccupied=GetGroups(A)
if ColumnsOccupied=1 then..... reject
or if ColumnsOccupied=2 or columnsoccupied=3 then....reject and so on.
Additional rules could be applied to the result array "A" which
after you called GetDgoups function contains return data. Not
the source data from the draws! Now it contains number of
each column occurances.
For example,
if ColumnOccupied>3 then
if a(1)=2 then .... reject
end if

Hope this is what you've asked for,
Good luck!
sss
 
P

PAB

Member
Hi sss,

Thank you very much for the time and effort you put into answering my request.
What I would ideally like to do is to get the Macro that GillesD kindly produced, to IGNORE the Combinations that DO NOT meet specific Criteria, and so DOES NOT output them to the Active Sheet.

The Basic Macro is :-

Option Explicit
Dim A As Integer
Dim B As Integer
Dim C As Integer
Dim D As Integer
Dim E As Integer
Dim F As Integer
Dim N As Long
Sub Combinations_649()
Range("A1").Select
Application.ScreenUpdating = False
N = 0
For A = 1 To 44
For B = A + 1 To 45
For C = B + 1 To 46
For D = C + 1 To 47
For E = D + 1 To 48
For F = E + 1 To 49
N = N + 1
If N = 65001 Then
N = 1
ActiveCell.Offset(-65000, 1).Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
ActiveCell.Value = A & "-" & B & "-" & C & "-" & D & "-" & E & "-" & F
ActiveCell.Offset(1, 0).Select
Next F
Next E
Next D
Next C
Next B
Next A
Application.ScreenUpdating = True
End Sub

What the MAIN objective to do is to IGNORE Combinations of 6 Numbers that have MORE than 4 Numbers in ANY ONE Group ( with Macro Code ). As you saw before a lot of Combinations are already IGNORED using Function Calls.

The Groups are quite rightly as you stated :-

Group 1 = 1, 6, 11, 16, 21, 26, 31, 36, 41, 46
Group 2 = 2, 7, 12, 17, 22, 27, 32, 37, 42, 47
Group 3 = 3, 8, 13, 18, 23, 28, 33, 38, 43, 48
Group 4 = 4, 9, 14, 19, 24, 29, 34, 39, 44, 49
Group 5 = 5, 10, 15, 20, 25, 30, 35, 40, 45

In an Ideal world it would be nice for the Macro to be flexible enough to be able to set Criteria ( directly in the Macro ) like :-

If I Wanted 4 Numbers in ANY ONE Group and the OTHER TWO Numbers in ONLY ONE OTHER Group then the Combination 1,3,6,8,11,16 would be Fine, but 1,3,4,6,11,16 would NOT and would therefore be IGNORED.
If I Wanted TWO Numbers in ANY THREE Groups then the Combination 1,2,3,6,7,8 would be Fine, but 1,2,3,4,6,7 would NOT and would therefore be IGNORED.
If I Wanted THREE Numbers in ONE Group, TWO Numbers in ONE OTHER Group and the Last Number in ONE OTHER Group then the Combination 1,2,3,6,7,11 would be Fine, but 1,2,3,4,6,11 would NOT and would therefore be IGNORED.

I know this is probably out of the question because of the complex programming.

Would it be a Simpler Solution to put the Groups into a WorkSheet ( Named "Group Criteria" for example ) and then Modify the Macro to Lookup the Groups and then EXCLUDE Combinations that DO NOT Meet the Criteria, so they are NOT Written to the WorkSheet ( Named "Combinations" for example )?.

In a Sheet Named "Group Criteria" the Groups could be Set-Up like :-
Group 1, A1=1, B1=6, C1=11, D1=16, E1=21, F1=26, G1=31, H1=36, I1=41, J1=46
Group 2, A2=2, B2=7, C2=12, D2=17, E2=22, F2=27, G2=32, H2=37, I2=42, J2=47
Group 3, A3=3, B3=8, C3=13, D3=18, E3=23, F3=28, G3=33, H3=38, I3=43, J3=48
Group 4, A4=4, B4=9, C4=14, D4=19, E4=24, F4=29, G4=34, H4=39, I4=44, J4=49
Group 5, A5=5, B5=10, C5=15, D5=20, E5=25, F5=30, G5=35, H5=40, I5=45

I look forward to receiving your views on this.

Once again thank you very much
Good Luck and all the Best
Paul
 
S

sss

Member
PAB said:
Hi sss,
What I would ideally like to do is to get the Macro that GillesD kindly produced, to IGNORE the Combinations that DO NOT meet specific Criteria, and so DOES NOT output them to the Active Sheet.
Click to expand...


Hi PAB,

Below is a code, but first some notes to let you understand exactly what is underneath that code.
1. According to how you split 49 numbers you have 5 Groups, or 5 Columns.
Any given 6 number combination can have its numbers belonging from single one column up to 5.
for example 10203 (1 number in col1, 2 numbers in col#3, and 3 nymbers in col#5, total 6 numbers)
or 10500, or 00330 and so on.
Now let's get rid of zeros. 10203 becomes 123, 10500 ->15, 00330 ->33
Final step: rearrange left to right descending. Got 321, 51, and 33
Question: how many possible patterns exist? Correct me if I'm wrong, roughly all they are as follows:

6
51
42
3111
321
33
21111
2211
222
11111


Having found a way to encode all possible grouping we get a tool to flexibly set validation criteria.
To make it easier let's assign self-explanatory constatns to patterns:
Const ALL_SIX_IN_ONE_GROUP=6
Const MORE_THAN_2_IN_ONE_GROUP1=33
Const MORE_THAN_2_IN_ONE_GROUP2=321
Const MORE_THAN_2_IN_ONE_GROUP3=3111
....
and so on...

Before writting a combination to excel spreadsheet you want to perform your group test,
and if test result satisfies your criteria then write, otherwise - ignore.

In a code below it corresponds to line:
ThisCriteria = TestCriteria

TestCriteria is a function which returns pattern of the given combination(A,B,...F)

Just one thing left: to check if ThisCriteria is ok and either reject it or to save:

If ThisCriteria = ALL_SIX_IN_ONE_GROUP Then
ActiveCell.Value = A & "-" & B & "-" & C & "-" & D & "-" & E & "-" & F
ActiveCell.Offset(1, 0).Select
If N = 65001 Then
N = 1
ActiveCell.Offset(-65000, 1).Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
End If

According to above you'll get in spreadsheet only those combinations, that have all 6 numbers
located in any of SINGLE ONE group. (If they were not rejected by previous checks you might have in code)
If you decide to choose another criteria you change "If ThisCriteria = ALL_SIX_IN_ONE_GROUP Then...."
to, for ex., "If ThisCriteria <> ALL_SIX_IN_ONE_GROUP or ThisCriteria=222 Then" .......

Function TestCriteria is called to test EVERY combination before saving or ignoring it.

Function getCriteria you call just once at the beginning to actually setup your criteria.
It is flexible: You can split your 49 numbers to as many groups as you like (1 to 49)
any group can have any numbers (1 to 49), they dom't have to be equal length...

You put your groups to the sheet with a "Group Criteria" name (or change its in getCriteria sub code)
Your main sheet should have name "Sheet1" (or change its name to your real one in getCriteria sub)
ALL groups(columns) must start in the row #1, no headers, no blanks. Left to write.
For example for 10 numbers lottery we decided to split 10 nums into 3 groups, group1=5nums, gr2=2,gr3=3 numbers.
1 6 8
2 7 9
3 10
4
5
..... and so on

Be prepared to wait on results much longer than before, cause it takes time.
Later on you may want to optimize it to reduce processing time...
=======================
Option Explicit
Option Base 1
Dim A As Integer
Dim B As Integer
Dim C As Integer
Dim D As Integer
Dim E As Integer
Dim F As Integer
Dim N As Long
Dim CriteriaColumns As Collection
Dim ColumnNumbers() As Integer
Dim TotalColumns As Integer
Dim ColumnCount() As Integer


Const ALLSIX = 6
Const FIVE_AND_ONE = 51
Const FOUR_ONE_ONE = 411
'and so on...
'42
'3111
'321
'33
'21111
'2211
'222
'11111

Sub Combinations_649()
Dim ThisCriteria As Integer
Range("A1").Select
Application.ScreenUpdating = False
getCriteria
N = 0
For A = 1 To 44
For B = A + 1 To 45
For C = B + 1 To 46
For D = C + 1 To 47
For E = D + 1 To 48
For F = E + 1 To 49
N = N + 1
ThisCriteria = TestCriteria
If ThisCriteria = ALLSIX Then
ActiveCell.Value = A & "-" & B & "-" & C & "-" & D & "-" & E & "-" & F
ActiveCell.Offset(1, 0).Select
If N = 65001 Then
N = 1
ActiveCell.Offset(-65000, 1).Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
End If
Next F
Next E
Next D
Next C
Next B
Next A
Application.ScreenUpdating = True
set CriteriaColumns=nothing
End Sub

Private Function TestCriteria() As Integer
Dim Done As Boolean
Dim i&, j&, Column&
Dim Arr(1 To 6) As Integer
Dim Ball As Integer
Dim Maximum As Integer
Dim strResult As String
Dim z As Variant


Arr(1) = A: Arr(2) = B: Arr(3) = C: Arr(4) = D: Arr(5) = E: Arr(6) = F

For Ball = 1 To 6
Done = False
For Column = 1 To TotalColumns
z = CriteriaColumns(Column)
j = UBound(z)
For i = 1 To j
If Arr(Ball) = z(i) Then
Done = True
Exit For
End If
Next
If Done Then Exit For
Next
ColumnCount(Column) = ColumnCount(Column) + 1
Next


strResult = ""
For i = 1 To TotalColumns
Maximum = -1
For j = 1 To TotalColumns
If ColumnCount(j) >= Maximum Then
Maximum = ColumnCount(j)
Ball = j
End If
Next
If Maximum > 0 Then strResult = strResult & Maximum
ColumnCount(Ball) = 0
Next

TestCriteria = CInt(strResult)

End Function

Private Sub getCriteria()
Dim col&, row&
Sheets("Group Criteria").Select
Set CriteriaColumns = New Collection
col = 1
Do While Trim(Cells(1, col)) <> ""
row = 1
ReDim ColumnNumbers(1)
Do While Trim(Cells(row, col)) <> ""
ReDim Preserve ColumnNumbers(row)
ColumnNumbers(row) = Cells(row, col)
row = row + 1
Loop
CriteriaColumns.Add ColumnNumbers
col = col + 1
Loop
TotalColumns = CriteriaColumns.Count
ReDim ColumnCount(TotalColumns)
Sheets("Sheet1").Select
End Sub


===========================
Good luck!
sss
 
Last edited:
P

PAB

Member
Hi sss,

A VERY big thank you for all the work you put into this.
The Pattern List needs to have 411 Added to it and 11111 Deleted.
I tried running the Macro this morning using 26 Numbers as a test, unfortunately it gave me a Run Time Error '6' Overflow.
I tried it using 12 ( 924 Combinations ) Numbers ( it Ran OK ) and only wanted Combinations with 2 Numbers in ANY THREE Groups. It Produced 100 Combinations. I set up an Excel Formula to check the Combinations Output and the Formula only showed SIX correct Answers, the Formula was showing a lot of 3's, 2's, 1's and 0's ( as below ).

It Produced the Following Results :-

Combinations Groups 1 2 3 4 5 Totals
1-2-6-7-11-12 Groups 3 3 0 0 0 Total 6
1-2-6-8-11-12 Groups 3 2 1 0 0 Total 6
1-2-6-9-11-12 Groups 3 2 0 1 0 Total 6
1-2-6-10-11-12 Groups 3 2 0 0 1 Total 6
1-2-7-8-11-12 Groups 2 3 1 0 0 Total 6
1-2-7-9-11-12 Groups 2 3 0 1 0 Total 6
1-2-7-10-11-12 Groups 2 3 0 0 1 Total 6
1-2-8-9-11-12 Groups 2 2 1 1 0 Total 6
1-2-8-10-11-12 Groups 2 2 1 0 1 Total 6
1-2-9-10-11-12 Groups 2 2 0 1 1 Total 6
1-3-6-7-11-12 Groups 3 2 1 0 0 Total 6
1-3-6-8-11-12 Groups 3 1 2 0 0 Total 6
1-3-6-9-11-12 Groups 3 1 1 1 0 Total 6
1-3-6-10-11-12 Groups 3 1 1 0 1 Total 6
1-3-7-8-11-12 Groups 2 2 2 0 0 Total 6 OK
1-3-7-9-11-12 Groups 2 2 1 1 0 Total 6
1-3-7-10-11-12 Groups 2 2 1 0 1 Total 6
1-3-8-9-11-12 Groups 2 1 2 1 0 Total 6
1-3-8-10-11-12 Groups 2 1 2 0 1 Total 6
1-3-9-10-11-12 Groups 2 1 1 1 1 Total 6
1-4-6-7-11-12 Groups 3 2 0 1 0 Total 6
1-4-6-8-11-12 Groups 3 1 1 1 0 Total 6
1-4-6-9-11-12 Groups 3 1 0 2 0 Total 6
1-4-6-10-11-12 Groups 3 1 0 1 1 Total 6
1-4-7-8-11-12 Groups 2 2 1 1 0 Total 6
1-4-7-9-11-12 Groups 2 2 0 2 0 Total 6 OK
1-4-7-10-11-12 Groups 2 2 0 1 1 Total 6
1-4-8-9-11-12 Groups 2 1 1 2 0 Total 6
1-4-8-10-11-12 Groups 2 1 1 1 1 Total 6
1-4-9-10-11-12 Groups 2 1 0 2 1 Total 6
1-5-6-7-11-12 Groups 3 2 0 0 1 Total 6
1-5-6-8-11-12 Groups 3 1 1 0 1 Total 6
1-5-6-9-11-12 Groups 3 1 0 1 1 Total 6
1-5-6-10-11-12 Groups 3 1 0 0 2 Total 6
1-5-7-8-11-12 Groups 2 2 1 0 1 Total 6
1-5-7-9-11-12 Groups 2 2 0 1 1 Total 6
1-5-7-10-11-12 Groups 2 2 0 0 2 Total 6 OK
1-5-8-9-11-12 Groups 2 1 1 1 1 Total 6
1-5-8-10-11-12 Groups 2 1 1 0 2 Total 6
1-5-9-10-11-12 Groups 2 1 0 1 2 Total 6
2-3-6-7-11-12 Groups 2 3 1 0 0 Total 6
2-3-6-8-11-12 Groups 2 2 2 0 0 Total 6 OK
2-3-6-9-11-12 Groups 2 2 1 1 0 Total 6
2-3-6-10-11-12 Groups 2 2 1 0 1 Total 6
2-3-7-8-11-12 Groups 1 3 2 0 0 Total 6
2-3-7-9-11-12 Groups 1 3 1 1 0 Total 6
2-3-7-10-11-12 Groups 1 3 1 0 1 Total 6
2-3-8-9-11-12 Groups 1 2 2 1 0 Total 6
2-3-8-10-11-12 Groups 1 2 2 0 1 Total 6
2-3-9-10-11-12 Groups 1 2 1 1 1 Total 6
2-4-6-7-11-12 Groups 2 3 0 1 0 Total 6
2-4-6-8-11-12 Groups 2 2 1 1 0 Total 6
2-4-6-9-11-12 Groups 2 2 0 2 0 Total 6 OK
2-4-6-10-11-12 Groups 2 2 0 1 1 Total 6
2-4-7-8-11-12 Groups 1 3 1 1 0 Total 6
2-4-7-9-11-12 Groups 1 3 0 2 0 Total 6
2-4-7-10-11-12 Groups 1 3 0 1 1 Total 6
2-4-8-9-11-12 Groups 1 2 1 2 0 Total 6
2-4-8-10-11-12 Groups 1 2 1 1 1 Total 6
2-4-9-10-11-12 Groups 1 2 0 2 1 Total 6
2-5-6-7-11-12 Groups 2 3 0 0 1 Total 6
2-5-6-8-11-12 Groups 2 2 1 0 1 Total 6
2-5-6-9-11-12 Groups 2 2 0 1 1 Total 6
2-5-6-10-11-12 Groups 2 2 0 0 2 Total 6 OK
2-5-7-8-11-12 Groups 1 3 1 0 1 Total 6
2-5-7-9-11-12 Groups 1 3 0 1 1 Total 6
2-5-7-10-11-12 Groups 1 3 0 0 2 Total 6
2-5-8-9-11-12 Groups 1 2 1 1 1 Total 6
2-5-8-10-11-12 Groups 1 2 1 0 2 Total 6
2-5-9-10-11-12 Groups 1 2 0 1 2 Total 6
3-4-6-7-11-12 Groups 2 2 1 1 0 Total 6
3-4-6-8-11-12 Groups 2 1 2 1 0 Total 6
3-4-6-9-11-12 Groups 2 1 1 2 0 Total 6
3-4-6-10-11-12 Groups 2 1 1 1 1 Total 6
3-4-7-8-11-12 Groups 1 2 2 1 0 Total 6
3-4-7-9-11-12 Groups 1 2 1 2 0 Total 6
3-4-7-10-11-12 Groups 1 2 1 1 1 Total 6
3-4-8-9-11-12 Groups 1 1 2 2 0 Total 6
3-4-8-10-11-12 Groups 1 1 2 1 1 Total 6
3-4-9-10-11-12 Groups 1 1 1 2 1 Total 6
3-5-6-7-11-12 Groups 2 2 1 0 1 Total 6
3-5-6-8-11-12 Groups 2 1 2 0 1 Total 6
3-5-6-9-11-12 Groups 2 1 1 1 1 Total 6
3-5-6-10-11-12 Groups 2 1 1 0 2 Total 6
3-5-7-8-11-12 Groups 1 2 2 0 1 Total 6
3-5-7-9-11-12 Groups 1 2 1 1 1 Total 6
3-5-7-10-11-12 Groups 1 2 1 0 2 Total 6
3-5-8-9-11-12 Groups 1 1 2 1 1 Total 6
3-5-8-10-11-12 Groups 1 1 2 0 2 Total 6
3-5-9-10-11-12 Groups 1 1 1 1 2 Total 6
4-5-6-7-11-12 Groups 2 2 0 1 1 Total 6
4-5-6-8-11-12 Groups 2 1 1 1 1 Total 6
4-5-6-9-11-12 Groups 2 1 0 2 1 Total 6
4-5-6-10-11-12 Groups 2 1 0 1 2 Total 6
4-5-7-8-11-12 Groups 1 2 1 1 1 Total 6
4-5-7-9-11-12 Groups 1 2 0 2 1 Total 6
4-5-7-10-11-12 Groups 1 2 0 1 2 Total 6
4-5-8-9-11-12 Groups 1 1 1 2 1 Total 6
4-5-8-10-11-12 Groups 1 1 1 1 2 Total 6
4-5-9-10-11-12 Groups 1 1 0 2 2 Total 6

I noticed that at the top of your post you showed :-
Const ALL_SIX_IN_ONE_GROUP=6
Const MORE_THAN_2_IN_ONE_GROUP1=33
Const MORE_THAN_2_IN_ONE_GROUP2=321
Const MORE_THAN_2_IN_ONE_GROUP3=3111

Then in the Macro you showed :-
Const ALLSIX = 6
Const FIVE_AND_ONE = 51
Const FOUR_ONE_ONE = 411
and
If ThisCriteria = ALLSIX Then

Does this make a difference?.
It is probably something I am doing wrong.

All the Best
PAB
 
S

sss

Member
PAB said:
Hi sss,

I tried running the Macro this morning using 26 Numbers as a test, unfortunately it gave me a Run Time Error '6' Overflow.
I tried it using 12 ( 924 Combinations ) Numbers ( it Ran OK ) and only wanted Combinations with 2 Numbers in ANY THREE Groups. It Produced 100 Combinations. I set up an Excel Formula to check the Combinations Output and the Formula only showed SIX correct Answers, the Formula was showing a lot of 3's, 2's, 1's and 0's ( as below ).

I noticed that at the top of your post you showed :-
Const ALL_SIX_IN_ONE_GROUP=6
Const MORE_THAN_2_IN_ONE_GROUP1=33
Const MORE_THAN_2_IN_ONE_GROUP2=321
Const MORE_THAN_2_IN_ONE_GROUP3=3111

Then in the Macro you showed :-
Const ALLSIX = 6
Const FIVE_AND_ONE = 51
Const FOUR_ONE_ONE = 411
and
If ThisCriteria = ALLSIX Then

Does this make a difference?.
It is probably something I am doing wrong.

All the Best
PAB
Click to expand...

Hi PAB,
I was able to successfully run macro on 26 numbers using your
criteria. When using 12 numbers I got such result:
====
1-2-3-6-7-8
1-2-3-6-8-12
1-2-3-7-8-11
1-2-3-8-11-12
1-2-4-6-7-9
1-2-4-6-9-12
1-2-4-7-9-11
1-2-4-9-11-12
1-2-5-6-7-10
1-2-5-6-10-12
1-2-5-7-10-11
1-2-5-10-11-12
1-3-4-6-8-9
1-3-4-8-9-11
1-3-5-6-8-10
1-3-5-8-10-11
1-3-6-7-8-12
1-3-7-8-11-12
1-4-5-6-9-10
1-4-5-9-10-11
1-4-6-7-9-12
1-4-7-9-11-12
1-5-6-7-10-12
1-5-7-10-11-12
2-3-4-7-8-9
2-3-4-8-9-12
2-3-5-7-8-10
2-3-5-8-10-12
2-3-6-7-8-11
2-3-6-8-11-12
2-4-5-7-9-10
2-4-5-9-10-12
2-4-6-7-9-11
2-4-6-9-11-12
2-5-6-7-10-11
2-5-6-10-11-12
3-4-5-8-9-10
3-4-6-8-9-11
3-4-7-8-9-12
3-5-6-8-10-11
3-5-7-8-10-12
3-6-7-8-11-12
4-5-6-9-10-11
4-5-7-9-10-12
4-6-7-9-11-12
5-6-7-10-11-12
====

1. Did you change loop like this?
For A = 1 To 7
For B = A + 1 To 8
For C = B + 1 To 9
For D = C + 1 To 10
For E = D + 1 To 11
For F = E + 1 To 12

2. Did you specify your criteria as
If ThisCriteria = 222 Then ... ?

3. Does your Group Criteria sheet has such data?
1 2 3 4 5
6 7 8 9 10
11 12 13 14 15
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

If so, it should work :confused:

As for "I noticed that at the top of your post you showed :-
Const ALL_SIX_IN_ONE_GROUP=6........." --
You can remove Constants definitions at all.

In your example for "only wanted Combinations with 2 Numbers in ANY THREE Groups. " you setup your test condition as

If ThisCriteria = 222 Then ...

If, for ex., you want to save all combinations that have THREE
numbers in any of group, you specify condition as

If ThisCriteria = 3111 or ThisCriteria = 321 or ThisCriteria = 33 then ...

Sometimes it's easier to use constants instead of numbers,
you can assign name to any number, e.g.
Const PAB1=3111
Const PAB2=321
Const PAB3=33

And then use

If ThisCriteria = PAB1 or ThisCriteria = PAB2 or ThisCriteria = PAB3 then ...

Which is essentially the same as previous "If" statement. It really doesn't matter.

Good luck!
sss
 
P

PAB

Member
Hi sss,
I Re-Run the Macro as per your instructions and it worked like a DREAM ( I tried 321 and 222 ) :agree: . It was obviously me doing something wrong the first time.
There are just two questions :-
(1) How would I be able to Produce Combinations that had say 321 AND 222.
(2) You said that the Processing time would be quite slow. Would it speed things up if you were to use a message box to tell you the Total Number of Combinations Produced and then give you the option to either print the Combinations to the WorkSheet or Exit :confused: .

Thank you very much for ALL your efforts :agree2: .
Good Luck and ALL the Best
PAB
:wavey:
 
S

sss

Member
PAB said:
Hi sss,
(1) How would I be able to Produce Combinations that had say 321 AND 222.
(2) You said that the Processing time would be quite slow. Would it speed things up if you were to use a message box to tell you PAB
:wavey:
Click to expand...

Hi PAB,
(1) - I'm not quite sure I understood correctly your question.
Any combination has one "code": 321, or 222, or 51, etc., right?
If you need 321's only, you query this "code" to be 321.
If ThisCriteria = 321 Then ...
If you need combinations 321 AND 222 then just approve these
two "codes": If ThisCriteria = 321 OR ThisCriteria = 222 Then ...
You can add more ORs in the same "If" statement.
If you want to get ALL combinations EXCEPT 321 & 222 then
If ThisCriteria <> 222 AND ThisCriteria <> 321 Then ...
As a result you'll get ALL BUT 222&321
And so on...

(2). What can REALLY help to substantially increase your
processing speed is to avoid Excel. Install VB, insert your
module in a new project. This will require very few changes,
compile it and get exe file. Which will work much faster, you
will be surprised :)
In that case you'll write result to a text file rather than to a
Excel spreadsheet. You can open the result file in Excel, if you choose so.
For now put DoEvents statement after the line "N=N+1",
hopefully it will allow you to cancel computations and see
data htat had already been written by that time...

Good luck!
sss
 
P

PAB

Member
Hi sss,

Brilliant. Exactly what I was after.
One Final question though. As you saw there are other Functions to be executed. If I was to incorporate the following Function where abouts would it fit into the Macro.

If SumAF Then

End If

Function SumAF()
SumAF = False
If A + B + C + D + E + F >= 21 And A + B + C + D + E + F <= 279 Then SumAF = True
End Function

I really appreciate the effort and time you have put in.
Good Luck and Thank You
PAB
 
S

sss

Member
PAB said:
Hi sss,
to be executed. If I was to incorporate the following Function where abouts would it fit into the Macro.

If SumAF Then

End If

PAB
Click to expand...

Hi PAB,
Function SumAF and most likely all other functions that you use
are much faster then extrimely slow getCriteria function. That's why you should place getCriteria call at the very end of a sequence of function calls.
One way to implement sequential calls (maybe not the best) is
like this:


If SumAF then
if AnyFunctionNameAF then
if AnotherFunctionNameAF then
if....
...
...
<and here goes final "heavy" getCriteria func>
ThisCriteria=GetCriteria
if ThisCriteria.... then
ActiveCell.Value = A & "-" & B & "-" & C & "-" & D & "-" & E & "-" & F
ActiveCell.Offset(1, 0).Select
If N = 65001 Then
N = 1
ActiveCell.Offset(-65000, 1).Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
end if
end if
end if
end if
end if
end if
end if

Good luck. BTW what lottery are you hunting at?
sss
 
P

PAB

Member
Hi sss,

Thanks for everything you have done and the BRILLIANT Macro. I will spend some time over the next few days trying to understand the Code and what is happening and why.
I play the UK 649 and Daily Play 727. I keep Excel DataBases for both with the assumption that the more Data you have the better chance you have of winning, when in fact we both know that EVERY Combination has as much Chance as ANY other. At the end of the day all we are trying to do is beat the System, and Even if we can only gain a slight edge, that surely gets us closer to "Winning That Ever Elusive JACKPOT".
Well we can all dream.

Thanks and Good Luck
PAB
:wavey:
 
S

sss

Member
PAB said:
Hi sss,

that EVERY Combination has as much Chance as ANY other. At the end of the day all we are trying to do is beat the System, and Even if we can only gain a slight edge, that surely gets us closer to "Winning That Ever Elusive JACKPOT".
Well we can all dream.

Thanks and Good Luck
PAB
:wavey:
Click to expand...

Who knows? One day dreams may become a reality ;)
Good luck to all nice people on this forum!:)
 
P

PAB

Member
Hi sss,

Sorry to trouble you again, I have tried Combining the Macro from the Thread "to maggie" with yours and have come up with the following. I have put little notes next to the bits I have either changed or Added. Unfortunately it DOES NOT work.
Could you please just cast your eyes over it and tell me where I have gone wrong.

Macro

Option Explicit
Option Base 1 <--- Why Option Base 1
Dim A As Integer
Dim B As Integer
Dim C As Integer
Dim D As Integer
Dim E As Integer
Dim F As Integer
Dim N As Long
Dim nMinA As Integer <--- ADDED
Dim nMaxF As Integer <--- ADDED
Dim CriteriaColumns As Collection
Dim ColumnNumbers() As Integer
Dim TotalColumns As Integer
Dim ColumnCount() As Integer

Sub Combinations_649()
Dim ThisCriteria As Integer
Range("A1").Select
Application.ScreenUpdating = False
getCriteria
N = 1 <--- CHANGED
Selection.ColumnWidth = 18 <--- ADDED
nMinA = 1 <--- ADDED
nMaxF = 16 <--- ADDED
For A = nMinA To nMaxF - 5 <--- CHANGED
For B = A + 1 To nMaxF - 4 <--- CHANGED
For C = B + 1 To nMaxF - 3 <--- CHANGED
For D = C + 1 To nMaxF - 2 <--- CHANGED
For E = D + 1 To nMaxF - 1 <--- CHANGED
For F = E + 1 To nMaxF <--- CHANGED
If N = 65001 Then <--- CHANGED
Selection.ColumnWidth = 18 <--- ADDED
If SumAF Then <--- ADDED
ThisCriteria = TestCriteria
If ThisCriteria = 222 Then
ActiveCell.Value = Application.WorksheetFunction.Text(A, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(B, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(C, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(D, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(E, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(F, "00") <--- ADDED
ActiveCell.Offset(1, 0).Select
If N = 65001 Then
Selection.ColumnWidth = 18 <--- ADDED
N = N + 1 <---CHANGED
ActiveCell.Offset(-65000, 1).Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
End If
End If <--- ADDED
End If <--- ADDED
Next F
Next E
Next D
Next C
Next B
Next A
Application.ScreenUpdating = True
set CriteriaColumns=nothing
End Sub

Function SumAF() <--- ADDED
SumAF = False <--- ADDED
If A + B + C + D + E + F >= 21 And A + B + C + D + E + F <= 60 Then SumAF = True <--- ADDED
End Function <--- ADDED

Private Function TestCriteria() As Integer
Dim Done As Boolean
Dim i&, j&, Column&
Dim Arr(1 To 6) As Integer
Dim Ball As Integer
Dim Maximum As Integer
Dim strResult As String
Dim z As Variant

Arr(1) = A: Arr(2) = B: Arr(3) = C: Arr(4) = D: Arr(5) = E: Arr(6) = F

For Ball = 1 To 6
Done = False
For Column = 1 To TotalColumns
z = CriteriaColumns(Column)
j = UBound(z)
For i = 1 To j
If Arr(Ball) = z(i) Then
Done = True
Exit For
End If
Next
If Done Then Exit For
Next
ColumnCount(Column) = ColumnCount(Column) + 1
Next

strResult = ""
For i = 1 To TotalColumns
Maximum = -1
For j = 1 To TotalColumns
If ColumnCount(j) >= Maximum Then
Maximum = ColumnCount(j)
Ball = j
End If
Next
If Maximum > 0 Then strResult = strResult & Maximum
ColumnCount(Ball) = 0
Next

TestCriteria = CInt(strResult)

End Function

Private Sub getCriteria()
Dim col&, row&
Sheets("Group Criteria").Select
Set CriteriaColumns = New Collection
col = 1
Do While Trim(Cells(1, col)) <> ""
row = 1
ReDim ColumnNumbers(1)
Do While Trim(Cells(row, col)) <> ""
ReDim Preserve ColumnNumbers(row)
ColumnNumbers(row) = Cells(row, col)
row = row + 1
Loop
CriteriaColumns.Add ColumnNumbers
col = col + 1
Loop
TotalColumns = CriteriaColumns.Count
ReDim ColumnCount(TotalColumns)
Sheets("Sheet1").Select
End Sub

Cheers and Good Luck
PAB
:wavey:
 
S

sss

Member
PAB said:
Hi sss,
following. I have put little notes next to the bits I have either changed or Added. Unfortunately it DOES NOT work.

Option Base 1 <--- Why Option Base 1
Dim nMinA As Integer <--- ADDED
ActiveCell.Value = Application.WorksheetFunction.Text(A, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(B, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(C, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(D, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(E, "00") & "-" _ <--- ADDED
& Application.WorksheetFunction.Text(F, "00") <--- ADDED

Cheers and Good Luck
PAB
:wavey:
Click to expand...

Hi PAB,

There are 3 options how to put VBA statements in text:
1. Each statement on a separate line
e.g.:
i=0
j=0
2. multiple statements in a line separated with a colon sign (":")
e.g.:
i=0: j=0
3. one long statement split by several lines, each line except
the last one has a " _" (space and underscore) as an indicator
that line is not ended yet:
e.g.
i=1+2+ _
3+4 _
+5+6

Ypu can put comments to any place of your code.
Comment start with a single quotation mark.
This quotation mark AND WHATEVER following it, is ignored by VBA.
If ypur comment is not preceded by quotation mark, VBA assumes
your comment to be a valid VBA code. And, as a result, it fails
to interpret it. So, instead of
Option Base 1 <--- Why Option Base 1
you shoul've written
Option Base 1 '<--- Why Option Base 1

In case of multiline statement (case 3 above) you can't put
comment at the end of the "broken" line. Place it before the
whole thing or after it.

As for Option Base 1 <--- Why Option Base 1:
VBA can treat arrays two ways:
1. Assuming the first item of an array has index 0,
2. ----- index 1.
If you Dim myArray(3), then in the first scenario you'll get
myArray with items myArray(0), ,yArray(1), myArray(2), (total3).
Second scenario: myArray(1), myArray(2),myArray(3), (total 3).
If you don't specify Option Base, then base 0 is defaulted.
In getCriteria all logic is based on an assumption that base is 1.
That's why I explicitly put base 1 to make it work properly.
BTW, if any of code you use besides getCriteria uses arrays,
you may have problems if this code assumes or forces base 0.
In that case you have to make sure your code is consistant in
regards to array base throughout ypur entire code....


Good luck!
sss
 
You must log in or register to reply here.

Sidebar

Top