Sub Test_birStarMatch2()
Dim c As Range, r As Range, a, aC, i As Integer, b
aC = Split("1137094 65535 11573124 8696052") 'colors
a = Split("950 615 708 968")
'a = Split("615")
'a = Split(InputBox("Enter sequence separated by space characters. e.g. 950 615 708 968", "Sequence"))
Set c = Range("R1:AG170")
For i = 0 To UBound(a)
b = aSingleIntegers(a(i))
Set r = briStarMatch(b, c)
If i = 0 Then c.Interior.Color = xlNone
If Not r Is Nothing Then
r.Interior.Color = aC(i)
End If
Next i
End Sub
'Big Range Integer values in array aV Star Match (all directions like a star)
'e.g. Array(1,5,33) up, down, left, right and 4 diagonals with the 3 integer values sequential
Function briStarMatch(aV, BigRange As Range) As Range
Dim r As Range, c As Range, f As Range
On Error Resume Next
For Each c In BigRange
Set r = riStarMatch(c, aV, BigRange)
If f Is Nothing Then Set f = r
Set f = Union(f, r)
Next c
If Not f Is Nothing Then Set briStarMatch = f
End Function
'Return Range with Matrix Matched values from 0 base array aV in all directions from one cell, bR.
Function riStarMatch(bR As Range, aV, BigRange As Range) As Range
Dim c As Range, r As Range, j, i As Integer, cc As Range
If bR <> CInt(aV(0)) Then Exit Function
'array element count, j
j = 1 + UBound(aV)
On Error Resume Next
With bR
'Left match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(0, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(0, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Top Left Diagonal match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Top match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, 0) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, 0))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Top Right Diagonal match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i * -1, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(i * -1, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Right match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(0, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(0, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Bottom Right Diagonal match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, i) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, i))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Bottom match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, 0) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, 0))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
'Bottom Left Diagonal match
Set c = bR 'Must have one match.
For i = 1 To UBound(aV)
If .Offset(i, i * -1) = CInt(aV(i)) Then Set c = Union(c, .Offset(i, i * -1))
Next i
If Err.Number <> 0 Then
Set c = Nothing
Err.Clear
End If
If j = c.Count And InRange(BigRange, c) Then
If r Is Nothing Then Set r = c
Set r = Union(r, c)
End If
End With
If Not r Is Nothing Then Set riStarMatch = r
End Function
Function InRange(BigRange, LittleRange) As Boolean
Dim r As Range
On Error Resume Next
Set r = Intersect(BigRange, LittleRange)
If r.Count = LittleRange.Count Then InRange = True
End Function
Function aSingleIntegers(s)
Dim a, i As Integer
ReDim a(0 To Len(s) - 1)
For i = 0 To Len(s) - 1
a(i) = CInt(Mid(s, i + 1, 1))
Next i
aSingleIntegers = a
End Function