Color code entire task row based on text in a certain column

[kre30a]

MS Project:

I have a current project plan with multiple tasks. I would like to know if there is a VBA solution to color code the entire row of a task based on the text in the status column.

If the status is "Complete", the row will be blue. If the status is "On Schedule", the status will be green. If the status is "Late", the row will be red. If the status is "Future Task", the row will be white.

[Rob Dak]

MS Project:

I have a current project plan with multiple tasks. I would like to know if there is a VBA solution to color code the entire row of a task based on the text in the status column.

If the status is "Complete", the row will be blue. If the status is "On Schedule", the status will be green. If the status is "Late", the row will be red. If the status is "Future Task", the row will be white.

[Rob Dak]

I am working on a similar type of Macro. I see your post is from 2016. Were you ever able to get this code completed? I am working on developing similar code. I have it started, but have a ways to go. My code loops through and highlights the past due tasks and sets the text to red. I also look at the %Complete value in the Gant Chart. I will next be working on highlighting the tasks that are due in the next two weeks, month and three months. I am working on creating the date range (two weeks March 17 - March 30) and then highlighting those tasks a different color.
If you have had luck, would you mind sharing your code? Thank you

[Rob Dak]

Sorry, I forgot the code. This is what I have now, and it gets the dates (and highlights everything from the two week start date going forward). I am not sure how to incorporate the two week end date. Your help would be greatly appreciated!

Sub HighlightTwoWks()
    ' Highlight due in next two weeks
    Dim T As Task
    ' Dim SubProjId As Long - subproject removal testing 3/20/17 rlh
    Dim TskSub As Task
    ' Get todays date
    ' Calculate date paramaters
    Dim Today
    Today = Date
    '   Two Weeks
    Dim TwoWeeksB As Date
    Dim TwoWeeksE As Date
    ' 2 Weeks
    ' Tomorrow through Today plus 14
    TwoWeeksB = DateAdd("D", 1, Today)
    TwoWeeksE = DateAdd("D", 14, Today)
    ' MsgBox ("Two Weeks Start Date:  " & (TwoWeeksB))
    ' MsgBox ("Two Weeks End Date:  " & (TwoWeeksE))
    MsgBox ("Two Week Range : " & (TwoWeeksB) & ": - " & (TwoWeeksE))
    ' Show all Sub-tasks
    SelectSheet
    OutlineShowAllTasks
    For Each T In ActiveProject.Tasks
        If Not T Is Nothing Then 
            If T.Subproject <> "" Then 
                SubProjId = T.ID
            ElseIf Not T.Summary Then 
                SelectRow Row:=SubProjId + T.ID, rowrelative:=False 
                Complete = Names & T.PercentComplete
                '    MsgBox Complete
                Names = Names & T.Finish
                ' test if task is 100% complete first and if so skip to next task on gant chart
                If T.PercentComplete <> 100 Then
                    '  If TwoWeeksB < T.Finish > TwoWeeksE Then
                    If T.Finish > TwoWeeksB Then
                        If T.Finish > TwoWeeksE Then
                            ' If T.Finish < TwoWeeksB And T.Finish > TwoWeeksE Then
                            Font32Ex CellColor:=49407
                            '  Font32Ex Color:=2366701
                        Else: Continue = True
                        End If
                    End If
                    Names = ""
                End If
            End If
        End If
    Next T
    EditGoTo ID:=1
    ' message to user that highlighting is done
    MsgBox ("Agent is complete")
End Sub