Sub Highlight_Adjacent_Cells()
Dim r As Range, b As Range, ncell As String
Dim k As Long, h As Long, resto As String, sNums As Variant
Application.ScreenUpdating = False
Set r = Range("B2:M13")
r.Interior.ColorIndex = xlNone
sNums = Array([O3] & [O4] & [O5], [O3] & [O5] & [O4], [O5] & [O3] & [O4])
For h = 0 To UBound(sNums)
Set b = r.Find(Left(sNums(h), 1), , xlValues, xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
For k = 1 To 8
resto = Mid(sNums(h), 2, Len(sNums(h)))
Call busca(r, resto, k, b.Row, b.Column, b)
Next
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
Application.ScreenUpdating = True
End Sub
Sub busca(r, resto, k, f, c, b)
Dim i As Long, j As Long, n As Long, m As Long
Select Case k
Case 1: f = f - 1: c = c + 0
Case 2: f = f - 1: c = c + 1
Case 3: f = f + 0: c = c + 1
Case 4: f = f + 1: c = c + 1
Case 5: f = f + 1: c = c + 0
Case 6: f = f + 1: c = c - 1
Case 7: f = f + 0: c = c - 1
Case 8: f = f - 1: c = c - 1
End Select
If f >= r.Rows(1).Row And f <= r.Rows(r.Rows.Count).Row _
And c >= r.Columns(1).Column And c <= r.Columns(r.Columns.Count).Column Then
If Cells(f, c) = Val(Mid(resto, 1, 1)) Then
For i = 2 To Len(resto)
For n = 1 To 8
Select Case n
Case 1: j = f - 1: m = c + 0
Case 2: j = f - 1: m = c + 1
Case 3: j = f + 0: m = c + 1
Case 4: j = f + 1: m = c + 1
Case 5: j = f + 1: m = c + 0
Case 6: j = f + 1: m = c - 1
Case 7: j = f + 0: m = c - 1
Case 8: j = f - 1: m = c - 1
End Select
If j >= r.Rows(1).Row And j <= r.Rows(r.Rows.Count).Row _
And m >= r.Columns(1).Column And m <= r.Columns(r.Columns.Count).Column Then
If Cells(j, m) = Val(Mid(resto, i, 1)) Then
b.Interior.ColorIndex = 6
Cells(f, c).Interior.ColorIndex = 6
Cells(j, m).Interior.ColorIndex = 6
End If
End If
Next n
Next i
End If
End If
End Sub
