Copper Contributor

Mar 10, 2023

Solved

If certain excel table cells are red, value =1

Hello,

I have an excel table that is currently 20 columns, B to U, but this number could increase.

Using conditional formatting rules, certain cells within a row will be either red or no color.

If any cell or cells, within a row, in columns F to O are red, column T of that row should change to a 1, otherwise a 0.

If either cell in column P or Q are red, column U should change to a 1, otherwise a 0.

Using VBA pieced together from online examples, online help, and existing functioning code, I have this:

Dim Tbl As ListObject
Dim MyRow As Long
Dim Versions As Range
Dim VersionFlag As Range
Dim License As Range
Dim LicenseFlag As Range
Set Tbl = ActiveSheet.ListObjects(1)
Set Versions = Range(Tbl.ListColumns("KLINOS").Range(1), Tbl.ListColumns("XJET VERSION").Range(1))

For this range, KLINOS starts the range at column F and XJET VERSION ends the range at column O.

Set VersionFlag = Range(Tbl.ListColumns("VERSION FLAG").Range(1), Tbl.ListColumns("VERSION FLAG").Range(1))

VERSION FLAG is column T.

Set License = Range(Tbl.ListColumns("ER LICENSE").Range(1), Tbl.ListColumns("SL LICENSE").Range(1))

For this range, ER LICENSE starts the range at column P and SL LICENSE ends the range at column Q.

Set LicenseFlag = Range(Tbl.ListColumns("LICENSE FLAG").Range(1), Tbl.ListColumns("LICENSE FLAG").Range(1))

LICENSE FLAG is column U.

Set rowselection = Selection
MyRow = ActiveCell.Row - Tbl.Range.Row
If Intersect(Versions, rowselection) Is Nothing Then
If Target.DisplayFormat.Interior.Color = vbRed Then
VersionFlag.Offset(MyRow).Value = 1
Else
VersionFlag.Offset(MyRow).Value = 0
End If
End If
If Intersect(License, rowselection) Is Nothing Then
If Target.DisplayFormat.Interior.Color = vbRed Then
LicenseFlag.Offset(MyRow).Value = 1
Else
LicenseFlag.Offset(MyRow).Value = 0
End If
End If

This code sort of works, but has the following problems:

-Regardless of what cell or cells within a row are red, both columns T and U of that row both change to a 1 instead of only cells within the defined ranges changing the corresponding T or U column.

-Once columns T and U of a row are a 1, if any cell within the row is changed from red to to no color, column T and U both change to a 0 instead of only changing once all cells within a row for the corresponding cell range are all changed to no color.

I have tried various version of similar code, all do not give the results I am hoping for.

Since the table could change size, I was using table header names, but if there is a better way to always reference the same header name regardless of what column it ends up in if table size changes, please advise.

Thanks in advance

Try this:

'Changes color of sheet tab according to SAM selection
Private Sub Worksheet_Change(ByVal Target As Range)
    If ActiveSheet.ListObjects(2).DataBodyRange(1, 4).Value > 0 Then
        Select Case Target.Value
            Case "Chris"
                Me.Tab.Color = vbRed
            Case "Jerry"
                Me.Tab.Color = vbGreen
            Case "John"
                Me.Tab.Color = vbBlue
            Case "Mike"
                Me.Tab.Color = vbYellow
        End Select
    End If

    'Adds version and license flag
    ActiveSheet.Unprotect "1"
    Application.EnableEvents = False
    Dim Tbl As ListObject
    Dim TblRow As ListRow
    Dim KIndex As Long
    Dim XIndex As Long
    Dim VFIndex As Long
    Dim EIndex As Long
    Dim SIndex As Long
    Dim LFIndex As Long
    Dim c As Long
    Dim f As Boolean
    Set Tbl = Me.ListObjects(1)
    KIndex = Tbl.ListColumns("KLINOS").Index
    XIndex = Tbl.ListColumns("XJET VERSION").Index
    VFIndex = Tbl.ListColumns("VERSION FLAG").Index
    EIndex = Tbl.ListColumns("ER LICENSE").Index
    SIndex = Tbl.ListColumns("SL LICENSE").Index
    LFIndex = Tbl.ListColumns("LICENSE FLAG").Index
    For Each TblRow In Tbl.ListRows
        If Not Intersect(TblRow.Range, Target) Is Nothing Then
            f = False
            For c = KIndex To XIndex
                If TblRow.Range(1, c).DisplayFormat.Interior.Color = vbRed Then
                    f = True
                    Exit For
                End If
            Next c
            TblRow.Range(1, VFIndex).Value = -f
            f = False
            For c = EIndex To SIndex
                If TblRow.Range(1, c).DisplayFormat.Interior.Color = vbRed Then
                    f = True
                    Exit For
                End If
            Next c
            TblRow.Range(1, LFIndex).Value = -f
        End If
    Next TblRow
    Application.EnableEvents = True
    ActiveSheet.Protect "1"
End Sub

HansVogelaar

MVP

Mar 10, 2023

chowell97

Could you attach a small sample workbook demonstrating the problem (without sensitive data), or if that is not possible, make it available through OneDrive, Google Drive, Dropbox or similar?

chowell97

Copper Contributor

Mar 11, 2023

HansVogelaar

I have attached the workbook.

There are notes on the Test sheet for the problems I tried to described.

Everything else within the workbook works as intended except for trying to add the version and license flag.

Thanks in advance

MVP

Try this:

'Changes color of sheet tab according to SAM selection
Private Sub Worksheet_Change(ByVal Target As Range)
    If ActiveSheet.ListObjects(2).DataBodyRange(1, 4).Value > 0 Then
        Select Case Target.Value
            Case "Chris"
                Me.Tab.Color = vbRed
            Case "Jerry"
                Me.Tab.Color = vbGreen
            Case "John"
                Me.Tab.Color = vbBlue
            Case "Mike"
                Me.Tab.Color = vbYellow
        End Select
    End If

    'Adds version and license flag
    ActiveSheet.Unprotect "1"
    Application.EnableEvents = False
    Dim Tbl As ListObject
    Dim TblRow As ListRow
    Dim KIndex As Long
    Dim XIndex As Long
    Dim VFIndex As Long
    Dim EIndex As Long
    Dim SIndex As Long
    Dim LFIndex As Long
    Dim c As Long
    Dim f As Boolean
    Set Tbl = Me.ListObjects(1)
    KIndex = Tbl.ListColumns("KLINOS").Index
    XIndex = Tbl.ListColumns("XJET VERSION").Index
    VFIndex = Tbl.ListColumns("VERSION FLAG").Index
    EIndex = Tbl.ListColumns("ER LICENSE").Index
    SIndex = Tbl.ListColumns("SL LICENSE").Index
    LFIndex = Tbl.ListColumns("LICENSE FLAG").Index
    For Each TblRow In Tbl.ListRows
        If Not Intersect(TblRow.Range, Target) Is Nothing Then
            f = False
            For c = KIndex To XIndex
                If TblRow.Range(1, c).DisplayFormat.Interior.Color = vbRed Then
                    f = True
                    Exit For
                End If
            Next c
            TblRow.Range(1, VFIndex).Value = -f
            f = False
            For c = EIndex To SIndex
                If TblRow.Range(1, c).DisplayFormat.Interior.Color = vbRed Then
                    f = True
                    Exit For
                End If
            Next c
            TblRow.Range(1, LFIndex).Value = -f
        End If
    Next TblRow
    Application.EnableEvents = True
    ActiveSheet.Protect "1"
End Sub

Forum Discussion

If certain excel table cells are red, value =1

Share

Resources