Coding to make tab colour change based on conditional formatting colour of cell range

Good Morning All,

I've got a workbook that has a couple of worksheets.

I have conditional formatting set up on all cells in the range F8 to AC47 which turns red if the date entered is over 6 months old.

As the first tab 'Section 1' will load up first and people won't always go into the second worksheet 'Section 2' I wanted to apply code to ws 'Section 2' so that the tab colour changes to red if any of the cells within the range F8 to AC47 are red due to the conditional formatting applied on them.

Basically so that it alerts the user that the second worksheet needs action as something is over 6 months old and so now 'out of date' so to speak.

And then the code would then make the tab colour go 'no colour' again once the red cell has been resolved and there are no red cells in the range F8 to AC47 again.

Any help would be much appreciated as I've been trying all sorts of coding but can't quite get it right.

Thanks
DC

Hi there,

Insert the following code into the ThisWorkbook VBA CodeModule and see if it does what you need:

Option Explicit


'=========================================================================================
'=========================================================================================


Const msDATE_CELLS As String = "F8:AC47"


'=========================================================================================
'=========================================================================================


Private Sub Workbook_Open()

    Dim wks As Worksheet

    For Each wks In ThisWorkbook.Worksheets
        Call SetTabColour(wks:=wks)
    Next wks

End Sub


'=========================================================================================
'=========================================================================================


Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    Call SetTabColour(wks:=Sh)
End Sub


'=========================================================================================
'=========================================================================================


Private Sub SetTabColour(wks As Worksheet)

    If mbOverdue(wks:=wks) = True Then
          wks.Tab.Color = vbRed
    Else: wks.Tab.Color = vbGreen
    End If

End Sub


'=========================================================================================
'=========================================================================================


Private Function mbOverdue(wks As Worksheet) As Boolean

    Const iOVERDUE  As Integer = 182

    Dim rDateCells  As Range
    Dim bOverDue    As Boolean
    Dim rCell       As Range

    bOverDue = False

    Set rDateCells = wks.Range(msDATE_CELLS)

    For Each rCell In rDateCells.Cells

        If IsDate(rCell.Value) Then

            If (Int(Now() - rCell.Value)) > iOVERDUE Then

                bOverDue = True
                Exit For

            End If

        End If

    Next rCell

    mbOverdue = bOverDue

End Function

The highlighted value can be altered to suit your own requirements.

Opening the workbook will set the tab colour of each worksheet appropriately.

When date values are changed on a worksheet, the tab colour of that worksheet will be set when the worksheet is deactivated, i.e. when a different worksheet is selected.



By including the following code it is possible to have the tab colour update each time the value of a date cell is changed, but it adds an (in my opinion) unnecessary overhead unless this facility is essential.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim rDateCells  As Range
    Dim iNoOfCells  As Integer
    Dim wks         As Worksheet

    On Error Resume Next
        iNoOfCells = 0
        iNoOfCells = Target.Cells.Count
    On Error GoTo 0

    If iNoOfCells = 1 Then

        If Target.Value <> 0 Then

            Set wks = Target.Parent

            Set rDateCells = wks.Range(msDATE_CELLS)

            If Not Intersect(Target, rDateCells) Is Nothing Then
                Call SetTabColour(wks:=wks)
            End If

        End If

    End If

End Sub

Hope this helps - please let me know how you get on.

Regards,

Greg M

Hi again,

Thanks for your prompt feedback.

Could you post a sample worksheet here? Even a sample which includes only the date cells range would be helpful, as it would enable me to see more clearly what you have in mind.

Regards,

Greg M

Kevin# - That works perfectly for what I needed, thanks a lot. Been driving me crazy all day that has.

Greg M, thanks a lot for your help as well, your coding worked perfectly if I based it on checking for dates in cells as opposed to colours so that is really helpful to know and something I will definitely need to use in the future so I will make a note of that.

Have a good day both.

DC

Hi again,

Thanks for that - glad you found my post useful.

Best regards,

Greg M