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
Adjust Color Depending on Another Cell’s Value
- This will adjust the color of a cell in column
Idepending on the value manually entered (not by formula) in column
A. If column
Adoesn’t contain a value from a list, the cell in the same row of column
Iwill get colored.
- If you already have values in column
A, you can simply select them and do a ‘copy/paste’, and the colors in column
Iwill be updated.
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Const sCriteriaList As String = "CBI,Fire,InCase,LEA" ' no spaces! 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
Your new idea requires changes in two lines:
Const sCriteriaList As String = "*BI,*EA,*PD,*SO,*TF" ' no spaces! If Application.Count(Application _ .Match(sCriteria, srg.Cells(r), 0)) = 0 Then
Answered By – VBasic2008
Answer Checked By – Clifford M. (AngularFixing Volunteer)