hello nco, pick3
excel 2010
I've changed a couple of conditions
- Extending the range covered by the sum of the digits to 7 - 19. (covers 75% theoretically) and a digit must have appeared in the previous 13 draws (again 75%)
I may have to start parameterizing things a bit soon, i.e. put some values as cells on the sheet and the user can vary them as currently, I have to keep on editing the code. However, before I can do that, I'll have to join a site where I can upload files.
In the meantime, you can experiment a bit because at the start, you are prompted to choose which filters you want to run and which you want to leave out.
Here's the latest version so far...
----------------------------------
Sub mFilterData()
Const DIALOG_BOX_TITLE = "Pick 3 Filtering"
'
Dim arrCurrPerm(2) As Byte
Dim arrMedDigits(9, 2) As Boolean
Dim arrPrevDraw(2) As Byte
Dim b As Byte
Dim b1 As Byte
Dim b2 As Byte
Dim b3 As Byte
Dim b10 As Byte
Dim b11 As Byte
Dim blnFilterFail As Boolean
Dim blnFltrAllEO As Boolean
Dim blnFltrAllHL As Boolean
Dim blnFltrTotal As Boolean
Dim blnFltrMedian As Boolean
Dim blnFltrPrevDrawSDP As Boolean
Dim blnFltrPrevDraw1D As Boolean
Dim bytNumEven As Byte
Dim bytNumOdd As Byte
Dim bytNumLow As Byte
Dim bytNumHigh As Byte
Dim bytNumInPrevDraw As Byte
Dim bytSumNums As Byte
Dim intNumRows As Integer
'
Sheets("Filtering").Select
'
' Initialising
'
' Clear the previous selection
Range("H2:J1001").ClearContents
'
' Setup
'
' Get the previous draw
Sheets("Filtering").Select
Range("F1").Select
Selection.End(xlDown).Offset(0, -5).Select
For b = 0 To 2
arrPrevDraw(b) = ActiveCell.Offset(0, b).Value
Next b
'
' Note which digits that have appeared in the previous 13 draws
For b1 = 0 To 12
For b2 = 0 To 2
arrMedDigits(ActiveCell.Offset(0, b2).Value, b2) = True
Next b2
ActiveCell.Offset(-1, 0).Select
Next b1
'
' Choose the filters to use
blnFltrAllEO = MsgBox("Remove if all three digits even or odd", vbYesNo, DIALOG_BOX_TITLE) = vbYes
blnFltrAllHL = MsgBox("Remove if all three digits 0-4 or 5-9", vbYesNo, DIALOG_BOX_TITLE) = vbYes
blnFltrTotal = MsgBox("Sum of digits in the range 7-19 (75%)", vbYesNo, DIALOG_BOX_TITLE) = vbYes
blnFltrMedian = MsgBox("Digit must have appeared in the last 13 draws (75%)", vbYesNo, DIALOG_BOX_TITLE) = vbYes
blnFltrPrevDrawSDP = MsgBox("Remove if digit in same position (1st/2nd/3rd) in the previous draw", vbYesNo, DIALOG_BOX_TITLE) = vbYes
blnFltrPrevDraw1D = MsgBox("One of the three digits must be in the previous draw", vbYesNo, DIALOG_BOX_TITLE) = vbYes
'
' Do the filtering
For b1 = 0 To 9
For b2 = 0 To 9
For b3 = 0 To 9
' Setup
arrCurrPerm(0) = b1: arrCurrPerm(1) = b2: arrCurrPerm(2) = b3 'Easier to work with arrays
blnFilterFail = False
'
' Eliminate rows containing all evens or all odds
If Not blnFilterFail Then
If blnFltrAllEO Then
bytNumEven = 0
bytNumOdd = 0
For b = 0 To 2
If (arrCurrPerm(b) Mod 2) = 0 Then
bytNumEven = bytNumEven + 1
ElseIf (arrCurrPerm(b) Mod 2) = 1 Then
bytNumOdd = bytNumOdd + 1
End If
Next b
'
If bytNumEven = 3 Then
blnFilterFail = True
ElseIf bytNumOdd = 3 Then
blnFilterFail = True
End If
End If
End If
'
' Eliminate rows containing all low (0-4) or high (5-9) numbers
If Not blnFilterFail Then
If blnFltrAllHL Then
bytNumLow = 0
bytNumHigh = 0
For b = 0 To 2
If arrCurrPerm(b) < 5 Then
bytNumLow = bytNumLow + 1
ElseIf arrCurrPerm(b) > 4 Then
bytNumHigh = bytNumHigh + 1
End If
Next b
'
If bytNumLow = 3 Then
blnFilterFail = True
ElseIf bytNumHigh = 3 Then
blnFilterFail = True
End If
End If
End If
'
' Keep if the sum of the digits between 7 and 19
If Not blnFilterFail Then
If blnFltrTotal Then
bytSumNums = 0
For b = 0 To 2
bytSumNums = bytSumNums + arrCurrPerm(b)
Next b
If bytSumNums < 7 Then
blnFilterFail = True
ElseIf bytSumNums > 19 Then
blnFilterFail = True
End If
End If
End If
'
' Eliminate rows that have digits that have not appeared in the last 13 draws
If Not blnFilterFail Then
If blnFltrMedian Then
For b = 0 To 2
If Not arrMedDigits(arrCurrPerm(b), b) Then
blnFilterFail = True
b = 2
End If
Next b
End If
End If
'
' Eliminate all arrangements where a digit is in the same position as the previous draw
If Not blnFilterFail Then
If blnFltrPrevDrawSDP Then
For b = 0 To 2
If arrCurrPerm(b) = arrPrevDraw(b) Then
blnFilterFail = True
b = 2
End If
Next b
End If
End If
'
' Keep if one and only one of the digits was in the previous draw
If Not blnFilterFail Then
If blnFltrPrevDraw1D Then
bytNumInPrevDraw = 0
For b10 = 0 To 2
For b11 = 0 To 2
If arrCurrPerm(b10) = arrPrevDraw(b11) Then
bytNumInPrevDraw = bytNumInPrevDraw + 1
b11 = 2
End If
Next b11
Next b10
If bytNumInPrevDraw <> 1 Then
blnFilterFail = True
End If
End If
End If
'
' Increment the row count if the arrangement has passed all filters
If Not blnFilterFail Then
For b = 0 To 2
Range("H2").Offset(intNumRows, b).Value = arrCurrPerm(b)
Next b
intNumRows = intNumRows + 1
End If
Next b3
Next b2
Next b1
'
Range("G1").Select
MsgBox intNumRows & " rows left after filtering", vbInformation
End Sub