Re: Calculate Sets and Subsets
Hi Ellis Dee,
OK then.
I entered 3 into cell "E4" for the number of combinations to evaluate but the program is still producing the same incorrect results that I posted earlier.
Is there a way I can print the Log.txt file to view it please.
Thanks in Advance.
All the Best.
PAB1
Re: Calculate Sets and Subsets
Just to use a quick example of trying to pin down the discrepancy, in your first post today you say that the following set of numbers...
Code:
1 2 3 4 5 6
1 2 3 7 8 9
3 5 6 7 8 9
...should produce 84 "2 if 3", while my program identifies only 74. Using the log file, here's all 74 "2 if 3" combinations that my program found:
Code:
C(1,2,4)
C(1,2,5)
C(1,2,6)
C(1,2,7)
C(1,2,8)
C(1,2,9)
C(1,3,4)
C(1,3,5)
C(1,3,6)
C(1,3,7)
C(1,3,8)
C(1,3,9)
C(1,4,7)
C(1,4,8)
C(1,4,9)
C(1,5,6)
C(1,5,7)
C(1,5,8)
C(1,5,9)
C(1,6,7)
C(1,6,8)
C(1,6,9)
C(1,7,8)
C(1,7,9)
C(1,8,9)
C(2,3,4)
C(2,3,5)
C(2,3,6)
C(2,3,7)
C(2,3,8)
C(2,3,9)
C(2,4,7)
C(2,4,8)
C(2,4,9)
C(2,5,6)
C(2,5,7)
C(2,5,8)
C(2,5,9)
C(2,6,7)
C(2,6,8)
C(2,6,9)
C(2,7,8)
C(2,7,9)
C(2,8,9)
C(3,4,5)
C(3,4,6)
C(3,4,7)
C(3,4,8)
C(3,4,9)
C(3,5,7)
C(3,5,8)
C(3,5,9)
C(3,6,7)
C(3,6,8)
C(3,6,9)
C(4,5,6)
C(4,5,7)
C(4,5,8)
C(4,5,9)
C(4,6,7)
C(4,6,8)
C(4,6,9)
C(4,7,8)
C(4,7,9)
C(4,8,9)
C(5,6,7)
C(5,6,8)
C(5,6,9)
C(5,7,8)
C(5,7,9)
C(5,8,9)
C(6,7,8)
C(6,7,9)
C(6,8,9)
Can you list the 10 missing combinations?
Re: Calculate Sets and Subsets
Quote:
Originally Posted by PAB1
Is there a way I can print the Log.txt file to view it please.
Did you really just ask me how to print a text file?
Double-click it to open it in notepad. Then from the File menu select Print.
Re: Calculate Sets and Subsets
Hi Ellis Dee,
Sorry, it is just that when I looked there wasn't a text file to open.
I will check the output you produced and get back to you.
Thanks Again.
All the Best.
PAB1
Re: Calculate Sets and Subsets
The log file has the same name as the excel file, but with "log" as the extension. So if the excel file is named PAB1.xls, the log file will be name PAB1.log.
Re: Calculate Sets and Subsets
Hi Ellis Dee,
I have just checked my figures and the missing 10 are ...
1 2 3
1 4 5
1 4 6
2 4 5
2 4 6
3 5 6
3 7 8
3 7 9
3 8 9
7 8 9
... which ALL have at least 2 numbers in common with any one of the 3 combinations ...
1 2 3 4 5 6
1 2 3 7 8 9
3 5 6 7 8 9
Thanks in Advance.
All the Best.
PAB1
Re: Calculate Sets and Subsets
I think I know what the problem might be. You want *AT LEAST*, but I went with *EXACTLY*. You never definitively answered me when I asked you to verify which you wanted, so I went with the specs in the OP, since you seemed to be more clear about what you wanted in your first post.
Is that the problem? If so, that fix is not trivial.
Re: Calculate Sets and Subsets
Yep, that's the problem alright. I'll take a quick look at the code and see if it's an easy fix, but I highly doubt it will be.
Re: Calculate Sets and Subsets
While I'm looking, did you ever find the log file?
Re: Calculate Sets and Subsets
It's an easy fix. Are you sure you want to change it to *AT LEAST*?
Re: Calculate Sets and Subsets
Thanks Ellis Dee,
I have been after trying to do this for about 2 to 3 years now and thanks to you I have NEVER been soo close.
This is not my computer, but YES, I finally found it in the backup drive after a search.
Yes, it has to be at "LEAST".
I really do appreciate all your time, effort and help.
Thanks in Advance.
All the VERY Best.
PAB1
Re: Calculate Sets and Subsets
Apologies if I've been rude to you today. I'm in a foul mood that has nothing to do with you.
Since it was such an easy fix, I added a constant to let you easily choose which way you want to go. It's at the very top of the module:
vb Code:
Private Const AtLeast = True ' Set to False to bucket exact matches
Setting it to False produces the earlier results; setting it to True produces the results you want. Not sure if you'll ever need to identify the exact matches, but I left the ability to do it that way "just in case".
To preserve the fix for posterity, (I'll eventually be removing these attachments,) the change included the constant noted above plus changes to the IdentifyMatches function:
vb Code:
Private Sub IdentifyMatches(pvarData As Variant, plngComb() As Long, plngNumbers As Long)
Dim x As Long
Dim i As Long
Dim lngCombinations As Long
Dim lngFound() As Long ' Array holding hits
Dim blnFound() As Boolean ' Flags preventing duplicate counts
Dim lngMatches As Long
Dim j As Long
Dim jMin As Long
' Save array boundary to variable to speed execution
lngCombinations = UBound(plngComb, 2)
' Initialize hits arrays
ReDim lngFound(2 To plngNumbers)
ReDim blnFound(2 To plngNumbers)
' Step through each generated combination
For i = 0 To lngCombinations ' Combinations start at 0, not 1
' Step through each entered data combination
For x = 1 To mlngRows
' Count number of matches
lngMatches = CountMatches(pvarData, x, plngComb, i, plngNumbers)
' Tally buckets
If AtLeast Then jMin = 2 Else jMin = lngMatches
If jMin < 2 Then jMin = 2
For j = jMin To lngMatches
If Not blnFound(j) Then
blnFound(j) = True
lngFound(j) = lngFound(j) + 1
End If
Next
Next
' Reset flags
For x = 2 To plngNumbers
blnFound(x) = False
Next
Next
' Display results
Sheets(StatsSheet).Select
For i = 2 To plngNumbers
If ShowCaptions Then
Cells(mlngOutputRow, mlngOutputColumn - 1).Value = i & " if " & plngNumbers
End If
Cells(mlngOutputRow, mlngOutputColumn).Value = lngFound(i)
mlngOutputRow = mlngOutputRow + 1
Range(GetColumnLetter(mlngOutputColumn) & mlngOutputRow).Select
Next
' Free memory
Erase blnFound, lngFound
End Sub
You can download this attachment to get the new version. Note that not every single number matches what you posted earlier today. (I'm not sure what the "# of 7" numbers even mean.)
Take a look and let me know if there are any discrepancies you need me to correct.
Re: Calculate Sets and Subsets
(Remember to set the UseLogFile constant to False to speed things up once you're confident in the program.)
Re: Calculate Sets and Subsets
Hi Ellis Dee,
No appologies needed. I often have days like that.
There is a seventh ball drawn which is the bonus ball, that is why there are categories for 2 if 7, 3 if 7, 4 if 7, 5 if 7, 6 if 7 & 7 if 7. The basics are exactly the same. These need to be calculated as a seperate entity I would assume although they go into the results list.
It would be nice if the x if y categories were sorted in ascending order for the x in the x if y because at the moment they are sorted for the y.
I will have a look at the code this evening.
Thanks in Advance.
All the Best.
PAB1
Re: Calculate Sets and Subsets
How come you don't have a "6 if 6" bucket in your results?
The bonus ball thing was a super-easy fix, and I decided to go ahead and transform the output despite it being a bit of a hassle. It'll still show each result in the old order as they are calculated in real-time, but at the very end they all get overwritten in the proper order.
The way the bonus ball works is with yet another constant defined at the very top of the module:
Code:
Private Const BonusBalls = 1
Turn the bonus ball on by setting the constant to 1; turn it off by setting it to 0.
Since every generated number matches your results upthread exactly, (woohoo! Success!), I've set the UseLogFile constant to False in this attachment. You can turn it on again easily enough if you ever have need to check the logic.
The only discrepancy is that this program will generate a few buckets not in your list. Namely "6 if 6" and "7 if 7". Every other bucket is reflected in your chart, and again every bucket is being calculated with the exact same total as in your chart.
Enjoy.
Re: Calculate Sets and Subsets
I could suppress the "6 if 6" and "7 if 7" buckets if that would help you.
Re: Calculate Sets and Subsets
Hi Ellis Dee,
Quote:
Originally Posted by Ellis Dee
I could suppress the "6 if 6" and "7 if 7" buckets if that would help you.
Leave it as it is please, they will be very useful.
I will look through the code tonight ( not that I will understand it ) and try to fathom out what does what and why.
I will let you know tomorrow how I get on.
Have a great evening.
All the Best.
PAB1
Re: Calculate Sets and Subsets
OUTSTANDING Ellis Dee :thumb: ,
Your Program is BRILLIANT.
I can't thank you enough for ALL your help, advice, time & patience. I must admit that I never thought this was going to be possible to achieve.
I am certainly going to try and understand what the code does and why, and then hopefully adapt it into the finished spreadsheet. The commented text throughout the code is sooo useful.
Ideally I would like it to produce the output in exactly the same way as the results table I posted ...
Code:
T if M Tested Covered % Not Covered %
----------------------------------------------------
2 If 2 : 36 33 91,66667 3 8,33333
2 If 3 : 84 84 100,00000 0 0,00000
2 If 4 : 126 126 100,00000 0 0,00000
2 If 5 : 126 126 100,00000 0 0,00000
2 If 6 : 84 84 100,00000 0 0,00000
2 If 7 : 36 36 100,00000 0 0,00000
3 If 3 : 84 54 64,28571 30 35,71429
3 If 4 : 126 126 100,00000 0 0,00000
3 If 5 : 126 126 100,00000 0 0,00000
3 If 6 : 84 84 100,00000 0 0,00000
3 If 7 : 36 36 100,00000 0 0,00000
4 If 4 : 126 44 34,92063 82 65,07937
4 If 5 : 126 114 90,47619 12 9,52381
4 If 6 : 84 84 100,00000 0 0,00000
4 If 7 : 36 36 100,00000 0 0,00000
5 If 5 : 126 18 14,28571 108 85,71429
5 If 6 : 84 53 63,09524 31 36,90476
5 If 7 : 36 36 100,00000 0 0,00000
6 If 7 : 36 9 25,00000 27 75,00000
... with ...
Cell "B9" and going down = x if y Categories ( Results already Produced ).
Cell "C9" and going down = FULL Combinations "Tested".
Cell "D9" and going down = Combinations "Covered" ( Results already Produced ).
Cell "E9" and going down = Percentage Covered "%".
Cell "F9" and going down = Combinations NOT Covered.
Cell "G9" and going down = Percentage NOT Covered "%".
... along with thousand seperators for "Tested", "Covered" & "Not Covered".
Thanks AGAIN.
Have a BRILLIANT Weekend.
All the Best.
PAB1
Re: Calculate Sets and Subsets
I'll take a look at it after the weekend. What would help is if you could set up the spreadsheet manually to look exactly as you want it and attach it here. Than I can have the program reproduce that automatically.
1 Attachment(s)
Re: Calculate Sets and Subsets
Thanks Ellis Dee,
I have attached the Excel file.
Have a GREAT Weekend.
All the Best.
PAB1
Re: Calculate Sets and Subsets
Hi, I am a newbie trying to code some ideas about sets and subsets, the code I will attach here, generate all possible combination of 24 numbers taken 6 at time and some direction apply. My problem or question is there are some definition out of my knolege (newbie), you can input how many odds and evens numbers, and sum range. Now what I really want to do is to import or storage a list of 2200 numbers in the code, so the new numbers generate by the code has to be compare and if find duplicate from the old list just delete, also from the sum range I want to turn off some values.
Code:
Option Explicit
'Various definitions requested
'1)odds and even will be input
'2)18 sum values will be avoid from the range
'3)a list of combinations to avoid will be input and storage
'4)the lis of combinations to avoid will be update any time
'5)the index number combination will be show
'6)Successful output ->sum range ->21 to 303 ->only those sum to these inclusive include in output
'=================================================================================================
'current definition are No. 1 and 6
'=================================================================================================
Public sumArr As Long, oddNo As Long, evenNo As Long, t As Long, oddNoReq As Long, lastRow As Long, _
evenNoReq As Long, minSumValue As Long, maxSumValue As Long, lRow As Long, testRow As Long, m As Long, minMaxRn As Long
Sub filtercombinations()
On Error GoTo errHandler
sortDataFirst
'********************************************************************************************************************************
'initialise variables
sumArr = 0: oddNo = 0: evenNo = 0: oddNoReq = 0: lastRow = 0: evenNoReq = 0: minSumValue = 0
maxSumValue = 0: lRow = 0: testRow = 0: m = 0: minMaxRn = 0
'Validate Data Entry Combination Definitions
If Range("B34") = vbNullString Or Range("B35") = vbNullString Or Range("B37") = vbNullString Or Range("B38") = vbNullString Then
MsgBox " enter the Number of Evens/Odds required in combination and the " & _
"Minimum Sum Value and Maximum Sum Value", vbExclamation
Exit Sub
End If
If Range("B37").Value > Range("B38").Value Then
MsgBox "The Minimum Sum must be less or iqual to the Maximum Sum", vbExclamation
Exit Sub
End If
If Range("B34").Value + Range("B35").Value <> 6 Then
MsgBox "You have entered an invalid combination of Even and Odd Numbers", vbExclamation
Exit Sub
End If
'Check max and min sum values
lastRow = lastRwCt
For m = 1 To 6
minMaxRn = minMaxRn + Cells(m, 1).Value
Next
If Range("B37").Value < minMaxRn Then
MsgBox "You have entered an invalid Sum Minimum value in the Combination Ouput Definition", vbExclamation
minMaxRn = 0
Exit Sub
End If
minMaxRn = 0
For m = lastRow - 5 To lastRow
minMaxRn = minMaxRn + Cells(m, 1).Value
Next
If Range("B38").Value > minMaxRn Then
MsgBox "You have entered an invalid Sum Maximum value in the Combination Ouput Definition", vbExclamation
minMaxRn = 0
Exit Sub
End If
'Data is valid - Set Requirements
oddNoReq = Range("B34")
evenNoReq = Range("B35")
minSumValue = Range("B37")
maxSumValue = Range("B38")
'********************************************************************************************************************************
Dim rRng As Range, p As Integer
Dim vElements, vresult As Variant
lRow = 1: testRow = 1
Set rRng = Range("A1", Range("A1").End(xlDown))
rRng.Select
p = 6
Dim q As Integer
Dim b As Double
b = 1
For q = 0 To p - 1
b = b * (lastRow - q) / (p - q)
Next q
MsgBox "No of Non repeating combinations is -> " & b, vbInformation
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Columns("C").Resize(, p + 15).Clear
headingsInsert
Call CombinationsNP(vElements, p, vresult, lRow, 1, 1)
MsgBox "There are " & lRow - 1 & " combinations that meet your output definition", vbInformation
Exit Sub
errHandler:
MsgBox "Error has occured - error no " & Err.Number & " - " & Err.Description
End Sub
Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer, k As Integer
On Error GoTo errHandler
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
'test array vresult for conditions as defined in data entry
For k = LBound(vresult) To UBound(vresult)
If vresult(k) Mod 2 <> 0 Then oddNo = oddNo + 1
If vresult(k) Mod 2 = 0 Then evenNo = evenNo + 1
sumArr = sumArr + vresult(k)
Next
If oddNo = oddNoReq And evenNo = evenNoReq And sumArr >= minSumValue And sumArr <= maxSumValue Then
lRow = lRow + 1
Range("C" & lRow).Resize(, p) = vresult
Range("I" & lRow) = sumArr
End If
testRow = testRow + 1
Range("k" & testRow).Resize(, p) = vresult
End If
If iIndex <> p Then
Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
End If
sumArr = 0
evenNo = 0
oddNo = 0
Next i
Exit Sub
errHandler:
MsgBox "Error has occured - error no " & Err.Number & " - " & Err.Description
End Sub
Sub headingsInsert()
Application.ScreenUpdating = False
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Range("D1:Q1").Copy
Sheets("Sheet1").Visible = False
Sheets("Combination Generation").Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Visible = False
Columns("I:I").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Application.ScreenUpdating = True
End Sub
Public Function lastRwCt() As Long
Dim o As Long
lastRwCt = Range("A1").CurrentRegion.Count
End Function
Sub sortDataFirst()
Range("A1:A24").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
any question, correction or advise welcome, thanks.