Adjacent cells change appearance based on cells' values

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
303
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hi Guy, need help to modify the code to add one more condition to trigger the change.
If the 1st cell value is "N' and adjacent cell value is "E", then change border style of both cells.
Also how to add code to let the change restore to original (no change) when conditions not met.
Thanks

VBA Code:
Dim c As Range, rng As Range, rng1 As Range

Set rng = Range("C3", Range("AL" & Rows.Count).End(xlUp))

For Each c In rng
    Select Case UCase(c.Value)
        Case "E", "N"
            Select Case UCase(c.Offset(, 1).Value)
                Case "D", "G"
                    Set rng1 = c.Resize(1, 2)
                    With rng1
                        .Borders.LineStyle = xlContinuous
                        .Borders.Weight = xlThick
                        '.Borders.Color = vbBlue
                        .Borders.Color = RGB(102, 0, 255)
                    End With
                            
            End Select
    End Select
Next
End If
End If

End Sub
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
303
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
To be more specific. The following five conditions should trigger the change
1st Cell value 2nd Cell value
E D
E G
N E
N D
N G

Hope somebody can help 🤣
 

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
499
Office Version
  1. 2016
Platform
  1. Windows
Hello Vincent88,
Try this...
VBA Code:
Sub HighlightPairs()

    Dim c As Range, rng As Range
    
    With ActiveSheet
        Columns("C:D").ClearFormats
        Set rng = Range("C3", Cells(Rows.Count, "C").End(xlUp))
        For Each c In rng
            Select Case UCase(c.Value) & UCase(c.Offset(0, 1).Value)
                Case "ED", "EG", "NE", "ND", "NG"
                    With c.Resize(, 2)
                        .Borders.LineStyle = xlContinuous
                        .Borders.Weight = xlThick
                        .Borders.Color = RGB(102, 0, 255)
                    End With
            End Select
        Next c
    End With
    
End Sub
 
Solution

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
303
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hi EXCEL MAX,
It works fine. Thanks a lot !
 

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
499
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

I'm glad if this was helpful.
 

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
303
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hello Vincent88,
Try this...
VBA Code:
Sub HighlightPairs()

    Dim c As Range, rng As Range
  
    With ActiveSheet
        Columns("C:D").ClearFormats
        Set rng = Range("C3", Cells(Rows.Count, "C").End(xlUp))
        For Each c In rng
            Select Case UCase(c.Value) & UCase(c.Offset(0, 1).Value)
                Case "ED", "EG", "NE", "ND", "NG"
                    With c.Resize(, 2)
                        .Borders.LineStyle = xlContinuous
                        .Borders.Weight = xlThick
                        .Borders.Color = RGB(102, 0, 255)
                    End With
            End Select
        Next c
    End With
  
End Sub
Hi EXCEL MAX, Further trial run found if the pair of cell meets the condition and the borders of pair cell are highlighted. If any of the cell contents is cleared, the highlighted borders do not restore to normal completely (See images) and all borders can only be restored when I enter data any other cells. Any suggestion to improve this !
 

Attachments

  • adjcell00.png
    adjcell00.png
    1.7 KB · Views: 1
  • adjcell01.png
    adjcell01.png
    2.5 KB · Views: 1
  • adjcell10.png
    adjcell10.png
    1.6 KB · Views: 1
Last edited by a moderator:

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
303
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hi EXCEL MAX,
I need to add more conditional to CASE to trigger the event but it may be too chunky to add conditions to CASE. Is it possible to use two groups of arrays in CASE ?
Array1 = ("E")
Array2=("D", "D1", "D2", "D3", "D4", "D5", "G", "K")
Array3=("N")
Array4=("D", "D1", "D2", "D3", "D4", "D5", "E","G", "K")


Something like
CASE Array1+Array2 and Array3+Array4 to trigger the change ?
 
Last edited:

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
499
Office Version
  1. 2016
Platform
  1. Windows
It seems easier to do that without Select Case...
VBA Code:
Sub HighlightPairs()

    Dim c As Range, rng As Range
    Dim Array1(), Array2(), Array3(), Array4(), Array5(), vA, vArrayX, _
         vNArraysSum As Long, vN As Long, vN1 As Long, vN2 As Long
    
    Array1 = Array("E")
    Array2 = Array("D", "D1", "D2", "D3", "D4", "D5", "G", "K")
    Array3 = Array("N")
    Array4 = Array("D", "D1", "D2", "D3", "D4", "D5", "E", "G", "K")
    Array5 = Array("ED", "EG", "NE", "ND", "NG")
    vA = Array(Array1, Array2, Array3, Array4, Array5)
    vNArraysSum = UBound(Array1) + _
                  UBound(Array2) + _
                  UBound(Array3) + _
                  UBound(Array4) + _
                  UBound(Array5) + _
                  UBound(vA)
    ReDim vArrayX(vNArraysSum)
    For vN1 = 0 To UBound(vA)
        For vN2 = 0 To UBound(vA(vN1))
            vArrayX(vN) = vA(vN1)(vN2)
            vN = vN + 1
        Next vN2
    Next vN1
    With ActiveSheet
        Columns("C:D").ClearFormats
        Set rng = Range("C3", Cells(Rows.Count, "C").End(xlUp))
        For Each c In rng
            For vN = 0 To UBound(vArrayX)
                If UCase(c.Value) & UCase(c.Offset(0, 1).Value) = _
                    vArrayX(vN) Then
                    With c.Resize(, 2)
                        .Borders.LineStyle = xlContinuous
                        .Borders.Weight = xlThick
                        .Borders.Color = RGB(102, 0, 255)
                    End With
                End If
            Next vN
        Next c
    End With
    
End Sub
 

Forum statistics

Threads
1,144,158
Messages
5,722,827
Members
422,460
Latest member
VBA_Noob01

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