My primary data entry is a Worksheet named "Master". I want to check in Range A2:A1000 when a word is entered. If it is "CBI", "Fire", "InCase" or "LEA" nothing needs to happen in Column I (Offset(0, 8)) as it already has a no-fill (Interior.ColorIndex = -4142). But, if any other word is entered in Range A2:A1000, Column I (Offset(0, 8)) is changed to a different color (Interior.Color = RGB(255, 231, 255)). I have selected the discrete worksheet with "Worksheet" and "Change" but cannot get the Intersect to function. I know the code is repetitive ... I would like to use multiple arguments, e.g., "CBI", "Fire", "InCase", "LEA" ... but it crashes at the firstIf Target line. Alternatively, a Select Case argument might be better. I have reviewed stackoverflow results on my search "run vba when cell change" and attempted to modify without success. I have also tried several coding attempts in the lone module where I have my other Subs which run fine, but help with this would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
'Change interior color in Offset cell if certain words not entered in Range A2:A1000
If Not Intersect(Target, Range("A2:A1000")) Is Nothing Then
If Target(Range("A2:A1000"), "CBI") > 0 Then
ActiveCell.Offset(0, 8).Interior.ColorIndex = -4142
Else
If Target(Range("A2:A1000"), "Fire") > 0 Then
ActiveCell.Offset(0, 8).Interior.ColorIndex = -4142
Else
If Target(Range("A2:A1000"), "InCase") > 0 Then
ActiveCell.Offset(0, 8).Interior.ColorIndex = -4142
Else
If Target(Range("A2:A1000"), "LEA") > 0 Then
ActiveCell.Offset(0, 8).Interior.ColorIndex = -4142
Else
ActiveCell.Offset(0, 8).Interior.Color = RGB(255, 231, 255)
End If
End If
End Sub
CodePudding user response:
Adjust Color Depending on Another Cell's Value
- This will adjust the color of a cell in column
I
depending on the value manually entered (not by formula) in columnA
. If columnA
doesn't contain a value from a list, the cell in the same row of columnI
will get colored. - If you already have values in column
A
, you can simply select them and do a 'copy/paste', and the colors in columnI
will be updated.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const sCriteriaList As String = "CBI,Fire,InCase,LEA"
Const sfCellAddress As String = "A2"
Const dCol As String = "I"
Dim diColor As Long: diColor = RGB(255, 231, 255)
Dim sfCell As Range: Set sfCell = Range(sfCellAddress)
Dim scrg As Range: Set scrg = sfCell.Resize(Rows.Count - sfCell.Row 1)
Dim srg As Range: Set srg = Intersect(scrg, Target)
If srg Is Nothing Then Exit Sub
Dim sCriteria() As String: sCriteria = Split(sCriteriaList, ",")
Dim drg As Range: Set drg = Intersect(srg.EntireRow, Columns(dCol))
Dim durg As Range
Dim r As Long
For r = 1 To srg.Cells.Count
If IsError(Application.Match(CStr(srg.Cells(r)), sCriteria, 0)) Then
If durg Is Nothing Then
Set durg = drg.Cells(r)
Else
Set durg = Union(durg, drg.Cells(r))
End If
End If
Next r
drg.Interior.Color = xlNone
If Not durg Is Nothing Then
durg.Interior.Color = diColor
End If
End Sub
CodePudding user response:
This can so easily be done, using conditional formatting. I have created the following rule:
=AND(A2<>"CBI",A2<>"Fire",A2<>"InCase",A2<>"LEA")
And applied it on my "B" column, as you can see in this screenshot:
And this is the result: