Option Explicit
Dim P2(0 To 31) As Long
Dim aG() As Long, aK() As Long, aKstart(1 To 35) As Long
Sub ph_match_5()
Dim rG As Range, rK As Range
Dim G As Long, K As Long, n As Long, i As Long, iKstart As Long
Dim v As Variant
Application.ScreenUpdating = False
'set powers of 2 array. skip 31 because that's sign bit
P2(0) = 1
For i = LBound(P2) + 1 To UBound(P2) - 1
P2(i) = 2 * P2(i - 1)
Next i
'setup G's
Set rG = ActiveSheet.Cells(1, 7)
Set rG = Range(rG, rG.End(xlDown))
rG.Interior.ColorIndex = xlColorIndexNone
ReDim aG(1 To rG.Rows.Count, 1 To 4)
ReDim aGLowHigh(1 To rG.Rows.Count, 1 To 2)
'setup K's
Set rK = ActiveSheet.Cells(1, 11)
Set rK = Range(rK, rK.End(xlDown))
rK.Interior.ColorIndex = xlColorIndexNone
ReDim aK(1 To rK.Rows.Count, 1 To 4)
ReDim aKLowHigh(1 To rK.Rows.Count, 1 To 2)
'build array of start of first element in K
For K = 1 To rK.Rows.Count
If K Mod 1000 = 0 Then
Application.StatusBar = "Building starting row of K, row " & Format(K, "#,##0")
DoEvents
End If
v = Split(rK.Cells(K, 1).Value, "-")
If aKstart(v(LBound(v))) = 0 Then aKstart(v(LBound(v))) = K
Next K
'map G's into bit array (1 - 16) into G(1), 17 - 32) into G(2), (33 - 48) into G(3), 49 - 64) into G(4)
'only using lower word (16 bits) to avoid negatives
For G = 1 To rG.Rows.Count
If G Mod 100 = 0 Then
Application.StatusBar = "Processing G bit maps, row " & Format(G, "#,##0")
DoEvents
End If
Call pvtStr2L1L2(rG.Cells(G, 1), aG(G, 1), aG(G, 2), aG(G, 3), aG(G, 4))
Next G
'map K's same way
For K = 1 To rK.Rows.Count
If K Mod 1000 = 0 Then
Application.StatusBar = "Processing K bit maps, row " & Format(K, "#,##0")
DoEvents
End If
Call pvtStr2L1L2(rK.Cells(K, 1), aK(K, 1), aK(K, 2), aK(K, 3), aK(K, 4))
Next K
'check for 3, 4 and 5 matches
For G = LBound(aG, 1) To UBound(aG, 1)
iKstart = CLng(Left(rG.Cells(G, 1).Value, InStr(rG.Cells(G, 1).Value, "-") - 1))
For K = aKstart(iKstart) To UBound(aK, 1)
If K Mod 1000 = 0 Then
Application.StatusBar = "Checking G = " & Format(G, "#,##0") & " against K = " & Format(K, "#,##0")
DoEvents
End If
If rK.Cells(K, 1).Interior.ColorIndex <> xlColorIndexNone Then GoTo NextK
n = 0
For i = LBound(aG, 2) To UBound(aG, 2)
n = n + pvtNumBits(aG(G, i), aK(K, i))
Next I
If n = 5 Then
rK.Cells(K, 1).Interior.Color = vbGreen
ElseIf n = 4 And rK.Cells(K, 1).Interior.ColorIndex = xlColorIndexNone Then
rK.Cells(K, 1).Interior.Color = vbYellow
ElseIf n = 3 And rK.Cells(K, 1).Interior.ColorIndex = xlColorIndexNone Then
rK.Cells(K, 1).Interior.Color = vbCyan
End If
NextK:
Next K
Next G
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Sub pvtStr2L1L2(s As String, L1 As Long, L2 As Long, L3 As Long, L4 As Long)
Dim v As Variant, v1() As Long
Dim i As Long
v = Split(s, "-")
ReDim v1(LBound(v) To UBound(v))
For i = LBound(v) To UBound(v)
v1(i) = CLng(v(i))
Next I
L1 = 0
L2 = 0
L3 = 0
L4 = 0
For i = LBound(v1) To UBound(v1)
Select Case v1(i)
Case 1 To 16
L1 = L1 + P2(v1(i))
Case 17 To 32
L2 = L2 + P2(v1(i) - 16)
Case 33 To 48
L3 = L3 + P2(v1(i) - 32)
Case 49 To 64
L4 = L4 + P2(v1(i) - 48)
End Select
Next i
End Sub
Function pvtNumBits(L1 As Long, L2 As Long) As Long
Dim n As Long
Dim L3 As Long
Dim i As Long
n = 0
L3 = L1 And L2
For i = 0 To 15
If (L3 And P2(i)) <> 0 Then n = n + 1
Next I
pvtNumBits = n
End Function