Highlight Adjacent Cells in a grid with 4 Numbers

Zippomann

New Member
Joined
Aug 27, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hello I am very new to excel and also this will be my 1st post I found a post by *Jlems May 27 2020 that basically does what I needed it to do called Highlight Adjacent Cells in a grid and they have it to find 3 numbers


grid.png


@DanteAmor

Put together a VBA code that does what was needed to do for a 3 number grid

VBA Code:
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

I was wondering if some would help or do the same type of code with a 4 numbers grid search I have no idea but I have managed to tweak *Jlems 3 number grid to suit my needs . I just do not know how to code but have found this program to be simply amazing. Started watching vids to learn Excel but this type is of stuff is way to advanced I do believe. Thanks
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

Zippomann

New Member
Joined
Aug 27, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
I was wondering if someone would help or do the same type of code with a 4 numbers grid search I have no idea, but I have managed to tweak *Jlems 3 number grid to suit my needs . I just do not know how to code, but have found this program to be simply amazing. Started watching vids to learn Excel but this type of stuff is way to advanced I do believe. Thanks
 
Upvote 0

bebo021999

Well-known Member
Joined
Jul 14, 2011
Messages
2,042
Office Version
  1. 2016
To help code more simple, it require there are 2 rows and 2 columns available from left and from top.
Click button "RUN" to execute

VBA Code:
Option Explicit
Sub highlight()
Dim i&, k&, Rc As Range, st As String, arr(1 To 100000, 1 To 1), num
Dim ce1 As Range, ce2 As Range, ce3 As Range, ce4 As Range
Dim Rce1 As Range, Rce2 As Range, Rce3 As Range, Rce4 As Range
Set Rc = Range("Q4:Q7")
Range("C3:N14").Interior.Color = xlNone
For Each ce1 In Range("C3:N14")
    With WorksheetFunction
        If .CountIf(Rc, ce1) Then
            Set Rce1 = ce1.Offset(-1, -1).Resize(3, 3)
            For Each ce2 In Rce1
                If .CountIf(Rc, ce2) And (ce2.Row = ce1.Row Or ce2.Column = ce1.Column) Then
                    Set Rce2 = ce2.Offset(-1, -1).Resize(3, 3)
                    For Each ce3 In Rce2
                        If .CountIf(Rc, ce3) And (ce3.Row = ce2.Row Or ce3.Column = ce2.Column) Then
                            Set Rce3 = ce3.Offset(-1, -1).Resize(3, 3)
                            For Each ce4 In Rce3
                                If .CountIf(Rc, ce4) And (ce4.Row = ce3.Row Or ce4.Column = ce3.Column) Then
                                    st = ce1 & ce2 & ce3 & ce4
                                    k = 0
                                    For Each num In Rc
                                        If InStr(1, st, num.Value) Then k = k + 1
                                    Next
                                    If k = 4 Then
                                        i = i + 1: arr(i, 1) = ce1.Address
                                        i = i + 1: arr(i, 1) = ce2.Address
                                        i = i + 1: arr(i, 1) = ce3.Address
                                        i = i + 1: arr(i, 1) = ce4.Address
                                   
                                    End If
                                End If
                            Next
                        End If
                    Next
                End If
            Next
        End If
    End With
Next
For Each ce1 In Range("C3:N14")
    For k = 1 To i
        If ce1.Address = arr(k, 1) Then
            ce1.Interior.Color = vbYellow
            Exit For
        End If
    Next
Next
End Sub
 
Upvote 0
Solution

Zippomann

New Member
Joined
Aug 27, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Thank you so very much for taking the time to help me with this. I changed the Range to B2:N14 and put the numbers 0,1 2,3, I got a Debug error at this line Set Rce2 = ce2.Offset(-1, -1).Resize(3, 3)
I changed them to
Set Rce2 = ce2.Offset(0, 0).Resize(3, 3) then got another Debug error at this line Set Rce3 = ce3.Offset(-1, -1).Resize(3, 3) changed that to Set Rce3 = ce3.Offset(0, 0).Resize(3, 3)
And this is what the grid looks like


4 Grid copy.png


So as you can see 0,1,2,3, works but I have extra highlighted numbers like H3,I3 F5,G5 were in the code does it need to be changed, I have no clue to be honest, but oh my this is so great thank you so much.
 
Upvote 0

bebo021999

Well-known Member
Joined
Jul 14, 2011
Messages
2,042
Office Version
  1. 2016
Thank you so very much for taking the time to help me with this. I changed the Range to B2:N14 and put the numbers 0,1 2,3, I got a Debug error at this line Set Rce2 = ce2.Offset(-1, -1).Resize(3, 3)
I changed them to
Set Rce2 = ce2.Offset(0, 0).Resize(3, 3) then got another Debug error at this line Set Rce3 = ce3.Offset(-1, -1).Resize(3, 3) changed that to Set Rce3 = ce3.Offset(0, 0).Resize(3, 3)
And this is what the grid looks like


View attachment 72957

So as you can see 0,1,2,3, works but I have extra highlighted numbers like H3,I3 F5,G5 were in the code does it need to be changed, I have no clue to be honest, but oh my this is so great thank you so much.
As I mentioned before in #3, to help code simple, it requires data start from C3 at least. (2 available rows and columns at least)
 
Upvote 0

Forum statistics

Threads
1,186,449
Messages
5,957,905
Members
438,330
Latest member
OCCY1221

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top