Option Explicit
Private Type Wheel
A As Currency
End Type
Private Type Digits
B(0 To 7) As Byte
End Type
Private BC(0 To 255) As Byte
' Private WHL(0 To 20) As Wheel ' Do not use 0th item
Private WHL() As Wheel ' Do not use 0th item
Private Tested As Long
Const POOL = 9
Sub Form_Load()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&
Dim iDataRows As Long
Dim i As Integer
' Build bit count lookup table
For idx = 0 To 255
BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
Next
' Enumerate different combinations
For cmb = 1 To POOL
tly = 0
For idx = 0 To (2 ^ POOL) - 1
If BitCount(idx / 5000) = cmb Then
tly = tly + 1
'If BitCount(idx / 5000)< cmb Then
' tlyn = tlyn + 1
' End If
End If
Next
Debug.Print "For 1 -"; POOL; "there are"; tly; "different combinations of"; cmb; "numbers."
Next
' SetWheel 1, 1, 2, 3, 4, 5, 9
' SetWheel 2, 1, 3, 5, 6, 7, 9
' SetWheel 3, 2, 4, 5, 6, 7, 8
iDataRows = [datastart].End(xlDown).Row - [datastart].Row
ReDim WHL(0 To iDataRows + 1)
For i = 0 To iDataRows
SetWheel2 i + 1
Next i
Debug.Print
Debug.Print "Result", "Covered", "(Tested)"
' Find matches
win = 7
For pik = 2 To win
For cmb = 2 To pik
Tested = 0
tly = Matching(cmb, pik, win)
Debug.Print cmb; "if"; pik, tly, "("; Tested; ")"
Next
Next
End Sub
Private Sub SetWheel2(Index As Long)
Dim vlu
Dim cell As Long
Dim bit As Long
Dim dgt As Digits
Dim Wh As Wheel
Dim i As Long
For i = 0 To 5
cell = [datastart].Offset(Index - 1, i) \ 8
bit = [datastart].Offset(Index - 1, i) And 7
dgt.B(cell) = dgt.B(cell) Or (2 ^ bit)
Next i
LSet Wh = dgt
WHL(Index).A = Wh.A
End Sub
Private Sub SetWheel(ByVal Index As Long, ParamArray Num())
Dim vlu, cell As Long, bit As Long
Dim dgt As Digits, Wh As Wheel
For Each vlu In Num
cell = vlu \ 8
bit = vlu And 7
dgt.B(cell) = dgt.B(cell) Or (2 ^ bit)
Next
LSet Wh = dgt
WHL(Index).A = Wh.A
End Sub
Private Function Matching(ByVal match As Long, ByVal pick As Long, ByVal win As Long) As Long
Dim op1 As Wheel, op2 As Wheel
Dim idx1 As Long, idx2 As Long
' Loop through all possible combinations
For idx1 = 0 To (2 ^ POOL)
' Limit to the 'if X' value
If BitCount(idx1 / 5000) = pick Then
op1.A = idx1 / 5000
DoEvents
Tested = Tested + 1
' Loop through items in wheel
idx2 = 1
While idx2< UBound(WHL) And WHL(idx2).A > 0
op2.A = WHL(idx2).A
idx2 = idx2 + 1
' Check for matching numbers
If BitCount(BigAnd(op1, op2)) >= match Then
Matching = Matching + 1
' Point to 0th item in wheel to exit loop
idx2 = 0
End If
Wend
End If
Next
End Function
Private Function BigAnd(W1 As Wheel, W2 As Wheel) As Currency
Dim d1 As Digits, d2 As Digits, d3 As Digits
Dim idx As Long
LSet d1 = W1
LSet d2 = W2
For idx = 0 To 7
d3.B(idx) = d1.B(idx) And d2.B(idx)
Next
LSet W2 = d3
BigAnd = W2.A
End Function
Private Function BitCount(ByVal X As Currency) As Long
Dim W As Wheel, d As Digits
Dim idx As Long, cnt As Long
W.A = X
LSet d = W
For idx = 0 To 7
cnt = cnt + BC(d.B(idx))
Next
BitCount = cnt
End Function
Private Function Nibs(ByVal Value As Byte) As Long
Select Case Value
Case 0
Exit Function
Case 1, 2, 4, 8
Nibs = 1
Exit Function
Case 3, 5, 6, 9, 10, 12
Nibs = 2
Exit Function
Case 7, 11, 13, 14
Nibs = 3
Exit Function
Case 15
Nibs = 4
End Select
End Function
