Conditional formatting based on value with offset

Question

I am looking for some help with the code for my issue. Cant quite figure out where to start. What i want to do, is to get a certain range(by use of offset), to be colored if a value in a cell, is equal to a name in a list.

I would like to do it by conditional formatting i Vba because i need to do it many times (it is a big sheet)

Example: In cell B5 the value is "Juliet". I have a list of names i column K and in column L i have colors. I want to conditional format range B3 to B6, if "juliet" Appears on the list, and in the color given next to "juliet".

I need to repeat itself, så the placement of "Juliet" could be anywhere, but always color the name, 2 cells above and 1 cell below.

Hope someone can help me get started the right way.

Edited

Sub Findname_and_Color()
Dim rng As Range

Dim cell As Range
Dim objColorStop As ColorStop
Dim ws As Worksheet

Application.ScreenUpdating = True

Set rng = Worksheets("Kalender").Range("F5:KI232") ' Adjust Range as needed
Set ws = Worksheets("xx")

For Each cell In rng.Cells
        Dim lastR As Long: lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        Dim rngNam As Range: Set rngNam = ws.Range("A2:A" & lastR)
        Dim f As Range, prevVal As String
        If cell.Value <> "" Then
            Set f = rngNam.Find(what:=cell.Value, LookIn:=xlValues, Lookat:=xlWhole)
            If Not f Is Nothing Then
                rng.Range(cell.Offset(-2, -5), cell.Offset(0, 0)).Interior.ColorIndex = f.Offset(, 3).Interior.ColorIndex
            End If

End If
Next cell
End Sub

Answer 1

Conditional Formatting is not suitable for changing other cells than the changed one. Please, copy the next code event in the sheet in discussion code module:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Count > 1 Then Exit Sub 'it works only for A SINGLE CELL CHANGE
   
   If Not Intersect(Target, Me.Range("A:H")) Is Nothing And Target.Row >= 3 Then
        Dim lastR As Long: lastR = Me.Range("K" & Me.Rows.Count).End(xlUp).Row
        Dim rngNam As Range: Set rngNam = Range("K2:K" & lastR)
        Dim f As Range, prevVal As String
        If Target.Value <> "" Then
            Set f = rngNam.Find(what:=Target.Value, LookIn:=xlValues, Lookat:=xlWhole)
            If Not f Is Nothing Then
                Me.Range(Target.Offset(-2), Target.Offset(1)).Interior.ColorIndex = f.Offset(, 1).Interior.ColorIndex
            End If
        Else
          Application.EnableEvents = False
            Application.Undo
            prevVal = Target.Value
            Target.Value = ""
            Set f = rngNam.Find(what:=prevVal, LookIn:=xlValues, Lookat:=xlWhole)
            If Not f Is Nothing Then
                Me.Range(Target.Offset(-2), Target.Offset(1)).Interior.ColorIndex = xlNone
            End If
          Application.EnableEvents = True
        End If
   End If
End Sub

It will also clear the cell interior when the name is cleared.

To see the sheet code module window, please right click on the sheet you try entering the respective names, choose View Code and paste the above code in the opening window.

Of course, you must have the mentioned Names (in "K:K" column) and the corresponding interior cells color in the next one ("L:L").

Edited:

If you need to use the reference names range from a different sheet, you should only replace:

   Dim lastR As Long: lastR = Me.Range("K" & Me.Rows.Count).End(xlUp).Row
   Dim rngNam As Range: Set rngNam = Range("K2:K" & lastR)

with:

   Dim sh As Worksheet: Set sh = Me.Parent.Worksheets("Sheet3") 'use here the sheet name you need
   Dim lastR As Long: lastR = sh.Range("K" & sh.Rows.Count).End(xlUp).Row
   Dim rngNam As Range: Set rngNam = sh.Range("K2:K" & lastR)

Everything remains as it is. You do not need to run any code, you should only update the names range/corresponding colors in the sheet you need...