Load into Array rather than Hard Coded

P

Paul Black

Hi everyone,

I have the following Program that evaluated the 3 SetWheels that were
Hard Coded in the Program.
What I would like the Program to do is pick up ALL the 6 number
combinations in the Excel sheet named "Data" and in Cells "B3:G?" and
evaluate those instead of those that are hard coded ( the combinations
will always start in Cell "B3" BUT the Cell "G?" will change depending
on the number of combinations to evaluate ).
The first combination is in Cells B3:G3, the second combination is in
Cells B4:G4 and so on. The combinations will be continuous down the
columns, and that there will be a blank row below the data.
What I would like please is to adapt the code between the *** so ALL
the combinations from the sheet named "Data" are used.

Here is the code :-

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

' Start ***************************************************
Dim WHL(0 To 20) As Wheel ' Do not use 0th item
' End *****************************************************

Private Tested As Long
Const POOL = 9

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&

' Build bit count lookup table
For idx = 0 To 255
BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
Next

Erase WHL

'SetWheel 1, 1, 2, 3, 4, 5, 9
'SetWheel 2, 1, 3, 5, 6, 7, 9
'SetWheel 3, 2, 4, 5, 6, 7, 8

' Start ***************************************************
Worksheets("Data").Select
If Range("B3:B3").Value <> 0 Then
SetWheel 1, Range("B3:G3").Value
End If

If Range("B4:B4").Value <> 0 Then
SetWheel 2, Range("B4:G4").Value
End If

If Range("B5:B5").Value <> 0 Then
SetWheel 3, Range("B5:G5").Value
End If
' End *****************************************************

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 SetWheel(ByVal Index As Long, ByVal Num As Variant)

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 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

Thanks in Advance.
All the Best.
Paul
 
J

Joel

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&

' Build bit count lookup table
For idx = 0 To 255
BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
Next

Erase WHL

'SetWheel 1, 1, 2, 3, 4, 5, 9
'SetWheel 2, 1, 3, 5, 6, 7, 9
'SetWheel 3, 2, 4, 5, 6, 7, 8

' Start ***************************************************
For WheelCount = 1 To 3
Select Case WheelCount
Case 1
RowCount = 3
Case 2
RowCount = 4
Case 3
RowCount = 5
End Select

Worksheets("Data").Select
If Range("B" & RowCount & ":B" & RowCount).Value <> 0 Then
SetWheel WheelCount, Range("B" & RowCount & ":B" & RowCount).Value
End If

' End *****************************************************

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
Next WheelCount

End Sub
 
P

Paul Black

Hi Joel,

Thanks very much for the reply.
As I said previously, there could be ANY number of 6 number
combinations to evaluate. Does your code only cater for 3 or am I
misreading it please.
I amended the code as you suggested to ...

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

' Start ***************************************************
Dim WHL(0 To 20) As Wheel ' Do not use 0th item
' End *****************************************************

Private Tested As Long
Const POOL = 9

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&

'ADDED **************************************************

Dim WheelCount As Integer
Dim RowCount As Integer

'************************************************************

' Build bit count lookup table
For idx = 0 To 255
BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
Next

Erase WHL

'SetWheel 1, 1, 2, 3, 4, 5, 9
'SetWheel 2, 1, 3, 5, 6, 7, 9
'SetWheel 3, 2, 4, 5, 6, 7, 8

' AMENDED ***************************************************

For WheelCount = 1 To 3
Select Case WheelCount
Case 1
RowCount = 3
Case 2
RowCount = 4
Case 3
RowCount = 5
End Select

Worksheets("Data").Select
If Range("B" & RowCount & ":B" & RowCount).Value <> 0 Then
SetWheel WheelCount, Range("B" & RowCount & ":B" &
RowCount).Value
End If

' ****************************************************************

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
Next WheelCount
End Sub

Private Sub SetWheel(ByVal Index As Long, ByVal Num As Variant)

Dim vlu, cell As Long, bit As Long
Dim dgt As Digits, Wh As Wheel
For Each vlu In Num
<------------------------------------------------------- ERROR
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 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

.... but get a Run-time error '13', Type mismatch on line ...

For Each vlu In Num

Thanks in Advance.
All the Best.
Paul
 
P

Paul Black

Hi again Joel,

As an after thought, would the amended code need to use "bits" instead
of conventional programming?. I only say this because I think I read
somewhere that using "bits" greatly increases the speed of processing
time and easier to manage.

Thanks Again.
All the Best.
Paul
 
J

Joel

I few comments
1) fix the Nibs function for tje case 0, it returns nothing

Private Function Nibs(ByVal Value As Byte) As Long
Select Case Value
Case 0
Nibs = 0 '<Add return zero
Exit Function

2) I only did the case for 3, the code is easily modified for additional
wheels.
3) Bit verses Bytes. I looked at the Nibs function and the way you coded is
probably the fastest method using Basic. Bits operations can be faster than
bytes. but it depends on the compiler and computer language you are usings.

Not sure what the code is actually trying to do. Don't have all the
functions. There may be some quicker methods of programming to speed
program. Using AND and OR functions are the best way of speeding the code
which is what is meant by "Using bits instead of conventional programming".
You have used the AND function, so I wouldn't worry too much unless the
program is running slow.
 
P

Paul Black

Thanks Joel,

My initial post above includes the full code after I made some
amendments to the original. Unfortunately I am still getting the same
error.
Here is the ORIGINAL FULL code ...

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 Tested As Long

Const POOL = 9

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Build Bit Count Lookup Table
For idx = 0 To 255
BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
Next

Erase WHL

SetWheel 1, 1, 2, 3, 4, 5, 9
SetWheel 2, 1, 3, 5, 6, 7, 9
SetWheel 3, 2, 4, 5, 6, 7, 8

Debug.Print
Debug.Print "Result", "Covered", "(Tested)"

' Find Matches
win = 7
For cmb = 2 To win
For pik = cmb To win
Tested = 0
tly = Matching(cmb, pik, win)
Debug.Print cmb; "if"; pik, tly, "("; Tested; ")"
Next
Next

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

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 the Wheel
idx2 = 1
While 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 the 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

... which works GREAT except for ONE thing I would like to change.
The Program calculates the three SetWheels that are hard coded.
What I would like the Program to do INSTEAD of this is to pick up ALL
the 6 number combinations in the sheet named "Data" and in Cells
"B3:G?" and process them INSTEAD. The first 6 number combination is in
Cells "B3:G3", the second 6 number combination is in Cells "B4:G4" etc
down to whatever the last 6 number combination is.
I would like it so that ALL the variables used and the subsequent
results produced throughout the Program are NOT affected by the
amendment(s). Basically, the amendment(s) need to integrate with the
rest of the code in the Program so it all still works correctly.

Thanks in Advance.
All the Best.
Paul
 
P

Paul Black

Hi Joel,

The output is produced in the immediate window.
The code I just posted is the ORIGINAL code which works great except
it picks up the hard coded combinations in the Program as opposed to
the combinations I want picked up from the spreadsheet.

Thanks in Advance.
All the Best.
Paul
 
J

Joel

Is this what you are looking for?

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&

' Build bit count lookup table
' For idx = 0 To 255
' BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
' Next

' Erase WHL

'SetWheel 1, 1, 2, 3, 4, 5, 9
'SetWheel 2, 1, 3, 5, 6, 7, 9
'SetWheel 3, 2, 4, 5, 6, 7, 8

' Start ***************************************************
For WheelCount = 1 To 3
Select Case WheelCount
Case 1
RowCount = 3
Case 2
RowCount = 4
Case 3
RowCount = 5
End Select

Worksheets("Data").Select

If Cells(RowCount, "B").Value <> 0 Then
SetWheel WheelCount, _
Cells(RowCount, "B").Value, _
Cells(RowCount, "C").Value, _
Cells(RowCount, "D").Value, _
Cells(RowCount, "E").Value, _
Cells(RowCount, "F").Value, _
Cells(RowCount, "G").Value

End If

' End *****************************************************

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
Next WheelCount

End Sub
 
P

Paul Black

Thanks Joel,

I amended the code and ran it.
It came up with an error variable not defined on line ...

For WheelCount = 1 To 3

Is there any other bits of code that need to be added or amended
please.

Thanks in Advance.
All the Best.
Paul
 
J

Joel

You have an explicit statement at the beginning of your code which means all
variables must be declared. Simply add wheelcount to your declarations

dim wheelcount as integer
 
P

Paul Black

Hi Joel,

I have done that in the Sub Generate but now it gives me :-

Complie error : Wrong number of arguments or invalid property
assignment for SetWheel ...

If Cells(RowCount, "B").Value <> 0 Then
SetWheel WheelCount, _

.... which I can't seem to overcome.

Thanks in Advance.
All the Best.
Paul
 
J

Joel

I'm going to lunch. Code below compiles. Note sure which variable is your
present wheel. We are getting your old code andnew code mixed up. Present
code puts the spreadsheet number in Num which I think becomes Whl. See if
you can fix the code. I'm hungry. Bye

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 Tested As Long

Const POOL = 9

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&
Dim Wheelcount, rowcount As Integer

' Build bit count lookup table
' For idx = 0 To 255
' BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
' Next

' Erase WHL

'SetWheel 1, 1, 2, 3, 4, 5, 9
'SetWheel 2, 1, 3, 5, 6, 7, 9
'SetWheel 3, 2, 4, 5, 6, 7, 8

' Start ***************************************************
For Wheelcount = 1 To 3
Select Case Wheelcount
Case 1
rowcount = 3
Case 2
rowcount = 4
Case 3
rowcount = 5
End Select

Worksheets("Data").Select

If Cells(rowcount, "B").Value <> 0 Then
SetWheel Wheelcount, _
Cells(rowcount, "B").Value, _
Cells(rowcount, "C").Value, _
Cells(rowcount, "D").Value, _
Cells(rowcount, "E").Value, _
Cells(rowcount, "F").Value, _
Cells(rowcount, "G").Value

End If

' End *****************************************************

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
Next Wheelcount

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 the Wheel
idx2 = 1
While 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 the 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
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
 
P

Paul Black

Hi Joel,

I ran the Program you posted and it produced the results three times
with "Covered" & "(Tested)" ALL empty.

Thanks in Advance.
All the Best.
Paul
 
J

Joel

I was very busy yesterday. got it right. Went back to original code that
you said worked perfectly. Then inserted my new code.

On wroksheet, column A is the wheel number 1 - 6. Columns B - G is the
input data.

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 Tested As Long

Const POOL = 9

Sub Generate()
Dim idx As Currency, tly&, cmb&, pik&, win&, output&, p&, tlyn&
Dim WheelCount, rowCount As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Build Bit Count Lookup Table
For idx = 0 To 255
BC(idx) = Nibs(idx And 15) + Nibs(idx \ 16)
Next

Erase WHL

'SetWheel 1, 1, 2, 3, 4, 5, 9
'SetWheel 2, 1, 3, 5, 6, 7, 9
'SetWheel 3, 2, 4, 5, 6, 7, 8


For WheelCount = 1 To 3
Select Case WheelCount
Case 1
rowCount = 3
Case 2
rowCount = 4
Case 3
rowCount = 5
End Select

Worksheets("Data").Select

If Cells(rowCount, "B").Value <> 0 Then
SetWheel WheelCount, _
Cells(rowCount, "B").Value, _
Cells(rowCount, "C").Value, _
Cells(rowCount, "D").Value, _
Cells(rowCount, "E").Value, _
Cells(rowCount, "F").Value, _
Cells(rowCount, "G").Value

End If

Debug.Print
Debug.Print "Result", "Covered", "(Tested)"

' Find Matches
win = 7
For cmb = 2 To win
For pik = cmb To win
Tested = 0
tly = Matching(cmb, pik, win)
Debug.Print cmb; "if"; pik, tly, "("; Tested; ")"
Next pik
Next cmb
Next WheelCount

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

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 the Wheel
idx2 = 1
While 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 the 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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Adding table into existing access database via ADO 0
if / then structure with macros 1
Alarm 2 2
Automatically copy with save? 8
Closing programs on remote PC - help please 1
A macro that counts cells when the conditional formatting formula =True. i.e. the cell is colored ot 5
VBA Loop through Specific Subfolders to find files (drill down 4 levels) 3
Excel Application to MS Access Application 2

Top