excelvbarangebyval

How do I use Change(byVal Target as Range) to check/change cell color


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

Solution

  • Adjust Color Depending on Another Cell's Value

    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
    

    EDIT: