Colour Entire Row Base on the Value of Two Other Cells

Are ya bored this holiday?
That Forceupdate colors won't work as is.

I now know how to make it work, but I'm still pondering the #38 attachment.

Take some holiday time and enjoy the celebration of the events of July 4, 1776.

This should do it. Obviously, you will have to do quite a bit of editing to put it in production.

I added to ability to click any vehicle sheets' Hours cell to activate the main sheets. corresponding cell for typing. ie, doubleclick the hours cell and type. Also, doubleclicking the Vehicle Reg cell on the main sheet, takes you to that Vehicle sheet.

When you close the book after editing, you will get an error because the CancelOntimes sub in modForce doesn't have an OnTime to cancel. Just End it.

Finally, If you click in cell A11 on each sheet and use the Windows menu >> Freeze Panes, the top of the sheet won't scroll out of sight.

More finally, please don't up;oad books that have been saved as "Read Only." My Excel v XP doesn't have that capability and I had to Save As new name all the time.

Hi SamT,

Just tried the new version. I like the double-click idea! but have some problems...

There appears to be a problem with the "colour updating" after main hour change or double click hours to next check. I update the hours and press enter, or double click the hours to next check, the message box pops up, I click ok and the cell selector cursor flashes blueish for a while. When it stops flashing, I find that the cell colours are unchanged. In sheet updating appears to work normally. Clearly the calculation is occurring but not providing the required colour output.

Unfortunately the code is above my brain cell grade, so can't quite figure out what's going on.

Also, am I to comment out the "'This line is a deliberate error etc etc" ?

Any ideas?

Many thanks as usual for all of your sterling efforts!!!

I thought that the sheets might need activating, so tried the following...

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)'Forces recoloring of sheet when vehicle hours are changed
  Select Case Target.Address
    Case "$H$6"
      Sheets("CD311").Activate
      Sheets("CD311").Calculate
      modForce.UpdateColors Sheets("CD311")
    Case "$H$8"
      Sheets("CD456").Activate
      Sheets("CD456").Calculate
      modForce.UpdateColors Sheets("CD456")
    Case "$H$10"
      Sheets("CD123").Activate
      Sheets("CD123").Calculate
      modForce.UpdateColors Sheets("CD123")
    Case "$H$12"
      Sheets("CD678").Activate
      Sheets("CD678").Calculate
      modForce.UpdateColors Sheets("CD678")
  End Select
End Sub

---

The colours start to change ok but then I get a Run time error 1004. "Method intersect of object" _Global Failed.

just inserted a

Code:

---

Sheets("Main").Activate

---

at the end of each modForce in the above code and the error has gone\, so I'll try a few combinations of hour inputs on the Main sheet to test all the sheets.

I have got the whole shibang integrated with my actual data and rolling but its very slow to update the colours after inputing hours on the main sheet and double click (30 seconds); probably because of having to unprotect and protect sheets.

Below is where I've stuck the unprotect statement.

Is there any way to speed things up?

Code:

---

Option ExplicitPublic Sub SetColors(sht As Worksheet, Cel As Range)


    Dim TimePriority As Long
    Dim DatePriority As Long
    Dim TaskPriority As Long
    Dim Rw As Long
    Dim i As Long
   
With sht
    Rw = Cel.Row
    ActiveSheet.Unprotect Password:="1234"
    TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
    DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol)) '<<<Changed from your Sheet Code!!!!
    TaskPriority = TimePriority
    If TaskPriority < DatePriority Then TaskPriority = DatePriority
   
    With .Cells(Rw, TaskCol).Font
        .Color = ColorByPriority(TaskPriority)
        .Bold = False
        If TaskPriority >= Priority4 Then .Bold = True Else .Bold = False
       
          End With
   
    ColoredHoursCells = Array("G", "I")
    For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
      .Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = ColorByPriority(TimePriority)
    Next i
    ColoredHoursCells = ""
   
    ColoredDaysCells = Array("N", "O")
    For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
      .Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = ColorByPriority(DatePriority)
    Next i
    ColoredDaysCells = ""
End With
ActiveSheet.Protect Password:="1234"
   
End Sub

---

Quote:

---

Also, am I to comment out the "'This line is a deliberate error etc etc" ?

---

Uh...Yeah. The Msgboxes are for debugging information only. ie, if you don't see "force Update Is Running. SecondTime is: something)" on the hour, that is a problem. If you don't see "Update Colors is running" on the hour and when you update Vehicle Hours on Sheet Main, that is a problem

The problems are totally my fault, I spread myself too thin this weekend and got burned out on VBA. Yours was the third or fourth (:Can't remember) good sized VBA project I worked on.

Really, you shouldn't need to Activate any sheet for this to work. The only reason for Acivating a sheet in the Main sheet's code is becaue you are moving to that sheet. BTW, on rethought, you probably want to remove the .Cells(TopMaintenanceRow... Select lines from that code. They force the sheet to scroll up to the top of the table. Not always what you want. BTW, if you Freeze Panes on Cell B11, the Task column will always be visible.

Doubleclicking the Vehicle Hours cell on a vehicle sheet shouldn't force a color update. It won't with the code below. It was triggering two separate Change events, not a "Good Thing!"

I see a brain fart in modForce. ForceUpdateColors; "TimeValue(DateAdd("h", 11, 0)), _" runs the code every 11 hours! Oops, Sorry. It should read "TimeValue(DateAdd("h", 1, 0)), _"

NOTE: THE ONLY WAY to test the code in this book is that after doing anything to it, you save and close the book, then reopen it and test the action on the sheets.

Try this "ThisWorkbook" code

Code:

---

Option Explicit
 

Private Sub Workbook_SheetChange(ByVal WkSht As Object, ByVal Target As Range)
Dim TrackChanges As Range
Set TrackChanges = Range(MaintenanceTable)
 
If WkSht Is Sheets("Main") Then Exit Sub
If Intersect(TrackChanges, Target) Is Nothing Then  Exit Sub

Application.EnableEvents = False
  modCellColoring.SetColors WkSht, Target
Application.EnableEvents = True

End Sub


Private Sub Workbook_Open()
Dim wks As Worksheet
    For Each wks In ThisWorkbook.Worksheets
        wks.Protect Password:="abc", UserInterfaceOnly:=True
    Next wks
   
  modForce.ForceUpdateColors
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  'Starts the sub that cancels automatic update colors.
  modForce.CancelOntimes
End Sub

---

This will be a bit faster because it only calls ColorByPiority twice instead of for every cell.

Code:

---

Option Explicit

Public Sub SetColors(sht As Worksheet, Cel As Range)

    Dim TimePriority As Long
    Dim TimeColor As Long
    Dim DatePriority As Long
    Dim DateColor As Long
    Dim TaskColor As Long
    Dim Rw As Long
    Dim i As Long
   
With sht
    Rw = Cel.Row
    TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
    DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol)) '<<<Changed from your Sheet Code!!!!
   
    TimeColor = ColorByPriority(TimePriority)
    DateColor = ColorByPriority(DatePriority)
    TaskColor = TimeColor
    If TimePriority < DatePriority Then TaskColor = DateColor
   
    With .Cells(Rw, TaskCol).Font
        .Color = TaskColor
        .Bold = False
        If TaskPriority >= Priority3 Then .Bold = True
    End With
   
    ColoredHoursCells = Array("F", "G", "I")
    For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
      .Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = TimeColor
    Next i
   
    ColoredDaysCells = Array("N", "O")
    For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
      .Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = DateColor
    Next i
   
End With
End Sub

---

Ok I'm trying the code; many thanks!

I keep getting Debug errors because I have all of the sheets in the workbook protected to avoid inadvertent formula overwriting by mistaken keyboard input. When I remove the protection, the code runs quickly enough but I lose the formula security. I need to maintain this during manual sheet entry; Soooo, in order for the new code to run, I need to unprotected the sheets under the two different color update methods and reprotect them on completion without having time for a coffee in between. Too much caffeine keeps me up digging through this as it is:coffee::coffee::coffee:

1) Hour input from the Main page.
2) Manual update of each sheet by task etc

At present the code runs in about 5 seconds with protection in the following points...

Code:

---

Public Sub UpdateColors(sht As Worksheet)'Called by ForceUpdatecolors above and Main sheet Change vehicle hours
MsgBox "Update Colors is running"

ActiveSheet.Unprotect Password:="123"

Dim Rw As Long
Dim Temp As Variant

With sht
  For Rw = TopMaintenanceRow To Sheets(sht.Name).LastRow '? It works, I'm tired
    Temp = Cells(Rw, TaskCol).Formula
    Cells(Rw, TaskCol).Formula = Temp
    DoEvents
  Next Rw
End With

ActiveSheet.Protect Password:="123"

End Sub

---

This almost works and is still fast enough (relocks after main input); but as soon as I input a new task on any sheet, the whole sheet unlocks and formulas become vulnerable. I have tried different locations for the re-protection but the code then takes the plus 30 seconds to run.

Quote:

---

Soooo, in order for the new code to run, I need to unprotected the sheets under the two different color update methods and reprotect them on completion

---

Did you try this code for speed? I don't believe it's necessary, but you might have to unprotect the sheets manually, save the book, and reopen it.

Code:

---

Private Sub Workbook_Open()
    Dim wks As Worksheet
    For Each wks In ThisWorkbook.Worksheets
        wks.Protect Password:="123", UserInterfaceOnly:=True
    Next wks

modForce.ForceUpdateColors
End Sub

---

NNNNNNNarrrrgg!!! Seems to be working now

for some reason it didn't work th first time round. Probably because I didn't follow your instructions to the letter. Sorry!!! Couldn't find an egg on my face smiley!!! :p Hope the stupid frog face will do.

At first glances everything seems good to go. I'll do some more testing with live data and get back.

SamT you are an ace.

Many thanks.

Hi SamT,

This morning when opening the workbook, some of the dates that should now be red remained yellow. I'd like the date colours to update on workbook opening if possible. Do I need to disable part of the ForceUpdateColors? I'm not concerned with waiting a few extra seconds as it'll provide me with the correct colours for each case immediately.

Lastly, and please excuse me being a continuous pain, can I add some code to the SetColors to fill the cells in Column "D" to the same colour as the font of that row?

Cheers for the assist and I hope to very shortly be out of your hair, yeah right you say

Quote:

---

Lastly, and please excuse me being a continuous pain, can I add some code to the SetColors to fill the cells in Column "D" to the same colour as the font of that row?

---

No!. Seriously, you don't want to do that. You wouldn't be able to see the words.

Check out this thread, Ontime vba opens another workbook that is not requested, It's anopther one with OnTime subs.

Quote:

---

I'd like the date colours to update on workbook opening if possible.

---

In modForce, remove the three lines with "SecondTme" in them, it is the Public Variable that prevents updating colors on book opening

Hi SamT,

Ref wanting to colour fill column "D" the same as the font in column "A". This column contains no text i.e. empty, so I just want to fill each cell of that column with the same colour as the font adjacent to it in column "A" of the same row. It'll highlight the row more.

Sorry brains gone dead on the SecondTime instruction. I can see the following lines with "SecondTme"...

1)

Code:

---

If SecondTime = True Then

---

2)

Code:

---

Public SecondTime As Boolean

---

3)

Code:

---

'SecondTime = True 'Prevents updating colors on book open

---

I guess I'll have to remove the EndIf as well after the SecondTime?

Also once this is done, After the workbook opens, I get "Force Update is Running" once, followed by "UpdateColor is running" four times but it appears as though the only sheet that gets the colour is the last active sheet before the previous save. I believe this is password orientated even though the

Code:

---

wks.Protect Password:="123", UserInterfaceOnly:=True

---

is present.

Also, If I save and close the workbook from Main, when I reopen, I get a runtime error "'1004' Application defined or object defined" after the first Update colores is running and stop at line...

Code:

---

Temp = Cells(Rw, TaskCol).Formula

---

in the code below

Code:

---

With sht  For Rw = TopMaintenanceRow To Sheets(sht.Name).LastRow '? It works, I'm tired
    Temp = Cells(Rw, TaskCol).Formula
    Cells(Rw, TaskCol).Formula = Temp
    DoEvents
  Next Rw
End With

---

In modCellColoring.SetColors , after coloring the taskcolumn

Code:

---

.Cells(Rw, BlankCol1).Interior.Color = [TimeColor|DateColor]

---

I have so many versions, I don't remember which one you're using. Or even if I have what you have.

I inserted an sheet activate and it seems to have done the trick.

Code:

---

or s = LBound(VehicleSheets) To UBound(VehicleSheets)        Set sht = Sheets(VehicleSheets(s))
        sht.Activate
        UpdateColors sht
      Next s

---

That said everything is working so far, so looks like I may have edited out the correct SecondTime lines.

Now all need to do is double check the Colour Logic/ Priority

Yes you are right, I have dozens now
My version

Code:

---

Option Explicit
Public Sub SetColors(sht As Worksheet, Cel As Range)
   
    Dim TimePriority As Long
    Dim TimeColor As Long
    Dim DatePriority As Long
    Dim DateColor As Long
    Dim TaskColor As Long
    Dim TaskPriority As Long
    Dim Rw As Long
    Dim i As Long
   
           
    With sht
        Rw = Cel.Row
        TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
        DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol)) '<<<Changed from your Sheet Code!!!!
       
        TimeColor = ColorByPriority(TimePriority)
        DateColor = ColorByPriority(DatePriority)
        TaskColor = TimeColor
        If TimePriority < DatePriority Then TaskColor = DateColor
       
                             
        With .Cells(Rw, TaskCol).Font
            .Color = TaskColor
            .Bold = False
            .Cells(Rw, BLankCol1).Interior.Color = [TimeColor|DateColor]
 
'gives object does not support this property or method. Must go somewhere else!


            If TaskPriority >= Priority4 Then .Bold = True
           
        End With
       
        ColoredHoursCells = Array("G", "I")
        For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
            .Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = TimeColor
           
        Next i
       
        ColoredDaysCells = Array("N", "O")
        For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
            .Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = DateColor
        Next i
               
    End With
   
    '
   
End Sub

---

Not quite sure where to put it. The above location gives a run time error "object does not support this property or method" I guess because the line deals with font colour?

After the "End With"

Code:

---

      With .Cells(Rw, TaskCol).Font
            .Color = TaskColor
            .Bold = False
            If TaskPriority >= Priority4 Then .Bold = True
        End With

          .Cells(Rw, BLankCol1).Interior.Color = TaskColor 'Adjust to suit

---

FYI, this is what your code says. Note that at the start of the sub, there is a "With Sht", and of course this section is inside a "With .Cells(Rw, TaskCol).Font"

Code:

---

Sht.Cells(Rw, TaskCol).Font.Color = TaskColor
Sht.Cells(Rw, TaskCol).Font.Bold = False
Sht.Cells(Rw, TaskCol).Font.Cells(Rw, BLankCol1).Interior.Color = TaskColor 'Adjust to suit. My bad instructions :(

---

Absolutely totally Flabbergasted :clap::clap::clap::friends::friends::friends::friends::beerchug::beerchug:: beerchug::beerchug::beerchug::beerchug::beerchug::beerchug::beerchug::beerc hug::beerchug::beerchug::beerchug::beerchug::beerchug::beerchug:

It's finished. All those beers are lined up for you at Cocorite, Port of Spain along with a big fat meal at the restaurant of your choice; no jokes. Your extreme patience is highly commendable and my thanks are little for the effort you have graciously afforded me.

Thanks SamT to you and all at vbaexpress.com and hope to see you soon!

If you really want to thank me, see my signature. PM me for details.

I don't think I will aver again travel the world.

I couldn't resist the temptation to stick to CF exclusively
I did the main sheet and sheet CD311.

Thanks very much snb. I'll take a look.

Hi SamT,

I pm'd you.

Final question for you. If I delete a Task from column "A"; at present, the adjacent cell "D" remains colour filled, but changes from whatever priority colour it was to Black filled. How can I now reset the cell colour fill in column "D" to no fill. Basically what's happening is that after sorting the Task column, Column "D" has black filled cells at the bottom where I have deleted Tasks.

Everything else is sweet!!

You can try setting it to vbApplicationWorkspace which might be white, or xlNone, which I have seen but never used. What you really want is to set the Interior's ColorIndex Property to xlColorIndexAutomatic.

The Interior's Color Property is both the simplest and the most complex way to set it's color. Simplest because you can use VBA's 8 ColorConstants, as we have been doing, and complex because you can use the RGB function to set it to any custom color you desire. IIRC, you've done that for one color.

The use of the ColorIndex Property lets you choose from any of the 56 colors in the color picker chart available when you format a Cells Fill. This has the advantage that you an modify any color in any Workbook by using the Color Tab in Excel's Tools >> Options Menu.

To set this up, you need to know the index numbers of the Color Picker Chart, which are not intuitive. In a column put these numbers in individual cells, -4105 (xlColorIndexAutomatic,) -4142 (xlNone and xlColorIndexNone), and the next 56 cells with the numbers 1 to 56.

Then run this routine

Code:

---

Sub ColorByIndex()
Dim Cel As Range

For Each Cel in Range("A1:A58")
Cel.Interior.ColorIndex = Cel.Value
Next
End Sub

---

Near the Priorities Enum paste this one and modify your existing Color Assignment routine to use these constants

Code:

---

Public Enum PriorityColors
  clrPriority0 = xlColorIndexAutomatic
  clrPriority1 = 37    'A blue
  clrPriority2 = 4    ' A Green
  clrPriority3 = 40  'an orangey color
  clrPriority4 = 3    ' Red
 End Enum

---

In the SetColors Routine, you will have to edit "Interior.Color" to"Interior.ColorIndex."

Run the routine to set your sheet's colors and then go into Excel's Options Dialog and on the Color Tab, select a color and click Modify. Go the the Custom Tab and play around. Use the generated list of colors by index to assign values to the Enum PriorityColors' Cosntants

Getting weird results. I've tried various combinations as it appears as though there will be two sets of Enums referring to priorities and colours in a duplicate kind of way!!! Is it because I need to remove the old Enum or add the second Enum. If I remove the old enum Priorities, I get undefined doofries etc. ? Basically if the TaskCol is empty from deleting a Task, there should be no colour in the "D" column.

My modPriorities and modCellColoring as below...

Code:

---

Option Explicit

Enum Priorities
  Priority0
  Priority1
  Priority2
  Priority3
  Priority4
End Enum




Function PriorityDays(Cel As Range) As Long
    If Cel.Value = "" Then
    PriorityDays = Priority0
    Exit Function
  End If
 
Select Case Cel.Value
  Case Is <= 0: PriorityDays = Priority4  'RED
  Case Is <= 7: PriorityDays = Priority3    'ORANGE
  Case Is <= 30: PriorityDays = Priority2  'GREEN
  Case Is <= 60: PriorityDays = Priority1    'BLUE
  Case Else: PriorityDays = Priority0        'BLACK
End Select
End Function


Function PriorityHours(Cel As Range) As Long
  If Cel.Value = "" Then
    PriorityHours = Priority0
    Exit Function
  End If
 
Select Case Cel.Value
  Case Is <= 0:  PriorityHours = Priority4  'RED
  Case Is <= 20: PriorityHours = Priority3  'ORANGE
  Case Is <= 50: PriorityHours = Priority2  'GREEN
  Case Is <= 100: PriorityHours = Priority1  'BLUE
  Case Else: PriorityHours = Priority0        'BLACK
End Select
End Function


Function ColorByPriority(priority As Long) As Long
  Select Case priority
  'BLACK
    Case 0: ColorByPriority = vbBlack
    'BLUE
    Case 1: ColorByPriority = vbBlue
    'GREEN
    Case 2: ColorByPriority = RGB(51, 204, 51)
    'ORANGE
    Case 3: ColorByPriority = RGB(255, 153, 0)
    'RED
    Case 4: ColorByPriority = vbRed
  End Select
End Function

---

Code:

---

Option Explicit
Public Sub SetColors(sht As Worksheet, Cel As Range)
   
    Dim TimePriority As Long
    Dim TimeColor As Long
    Dim DatePriority As Long
    Dim DateColor As Long
    Dim TaskColor As Long
    Dim TaskPriority As Long
    Dim Rw As Long
    Dim i As Long
   
           
    With sht
        Rw = Cel.Row
        TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
        DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol)) '<<<Changed from your Sheet Code!!!!
       
        TimeColor = ColorByPriority(TimePriority)
        DateColor = ColorByPriority(DatePriority)
        TaskColor = TimeColor
        If TimePriority < DatePriority Then TaskColor = DateColor
       
                             
        With .Cells(Rw, TaskCol).Font
            .Color = TaskColor
            .Bold = False
           
            If TaskPriority >= Priority4 Then .Bold = True
           
        End With
       
        .Cells(Rw, BLankCol1).Interior.Color = TaskColor 'Adjust to suit
       
        ColoredHoursCells = Array("G", "I")
        For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
            .Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = TimeColor
           
        Next i
       
        ColoredDaysCells = Array("N", "O")
        For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
            .Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = DateColor
        Next i
               
    End With
       
End Sub

---

An Enum Statement is handy for when you need a bunch of similarly named Constants and their actual values aren't important. Note that in your previous code, The actual values of the Priorities Constants were only used in the ColorByPriority Function to select an actual color. Ironically, the color was just another blind Constant whose actual value was not important to you, the programmer.

BTW, Enum stands for Enumerated Constants. If you don't assign values to the Constants, their values will start at 0 and increment by 1 for each consecutive Constant.

Note that the actual Values of the Enums are passed bwtween the various Functions and Sub SetColors.

I would suggest that you place the Enum PriorityColrs in modVariablesAndConstants, since that is where all other Constant Values that may need to be changed are located.

Code:

---

Public Enum PriorityColors
 'Resulting Color in Comments
 'Set = to selected Color Picker Index number
    clrPriority0 = xlColorIndexAutomatic 'Color of Excel's Standard Font (= -4105)
    clrPriority1 = 37 'A blue
    clrPriority2 = 4  'A Green
    clrPriority3 = 40 'an orangey color
    clrPriority4 = 3  'Red
End Enum

---

Code:

---

Enum Priorities
'Actual values in Comments
    Priority0 '0
    Priority1 '1
    Priority2 '2
    Priority3 '3
    Priority4 '4
End Enum
 
 
Function PriorityDays(Cel As Range) As Long
    If Cel.Value = "" Then
        PriorityDays = Priority0
        Exit Function
    End If
   
    Select Case Cel.Value
    Case Is <= 0: PriorityDays = Priority4
    Case Is <= 7: PriorityDays = Priority3
    Case Is <= 30: PriorityDays = Priority2
    Case Is <= 60: PriorityDays = Priority1
    Case Else: PriorityDays = Priority0
    End Select
End Function
 
 
Function PriorityHours(Cel As Range) As Long
    If Cel.Value = "" Then
        PriorityHours = Priority0
        Exit Function
    End If
   
    Select Case Cel.Value
    Case Is <= 0:  PriorityHours = Priority4
    Case Is <= 20: PriorityHours = Priority3
    Case Is <= 50: PriorityHours = Priority2
    Case Is <= 100: PriorityHours = Priority1
    Case Else: PriorityHours = Priority0
    End Select
End Function
 
 
Function ColorByPriority(priority As Long) As Long
    Select Case priority
    Case Priority0: ColorByPriority = clrPriority0
    Case Priority1: ColorByPriority = clrPriority1
    Case Priority2: ColorByPriority = clrPriority2
    Case Priority3: ColorByPriority = clrPriority3
    Case Priority4: ColorByPriority = clrPriority4
    End Select
End Function

---

Code:

---

Public Sub SetColors(sht As Worksheet, Cel As Range)
   
    Dim TimePriority As Long
    Dim TimeColor As Long
    Dim DatePriority As Long
    Dim DateColor As Long
    Dim TaskColor As Long
    Dim TaskPriority As Long
    Dim Rw As Long
    Dim i As Long

    With sht
        Rw = Cel.Row
        TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
        DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol)) '<<<Changed from your Sheet Code!!!!
       
        TimeColor = ColorByPriority(TimePriority)
        DateColor = ColorByPriority(DatePriority)
        TaskColor = TimeColor
        If TimePriority < DatePriority Then TaskColor = DateColor
       
        With .Cells(Rw, TaskCol).Font
            .Color = TaskColor
            .Bold = False
            If TaskPriority >= Priority4 Then .Bold = True
        End With
       
        .Cells(Rw, BLankCol1).Interior.ColorIndex = TaskColor 'Adjust to suit
       
        ColoredHoursCells = Array("G", "I")
        For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
            .Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = TimeColor
        Next i
       
        ColoredDaysCells = Array("N", "O")
        For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
            .Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = DateColor
        Next i
    End With
End Sub

---

OK, colours are working in column "D". Some of the cells in that column, that are not colored, don't appear to have borders. Also, the font in columns "A", "G", "I", "N" and "O" are really faint to the point of being unreadable. Not sure whats happening there.

Go back to my post where I showed you how to discover the index numbers in the Color Picker chart, and adjust the values of the PriorityColors Constants as desired. I just picked some that looked close.Unfortunately, you can't use vbBlack if you're going to color interiors. AFAIK, there is no vbNone color constant.

I've had to add a priority level in order to have Black as an option for cell and font colour for values greater than 100 hours or 60 days.
This then leaves clrPriority0 for -4142 (xlNone and xlColorIndexNone. I did however have to reverse the order of priorities for the bold option(I think).

The font is still not changing colour as desired (my lack of coding skill), so I still have not grasped the entire picture. My row formulas currently use hour and calendar period row "empty check" formulas. This means there are no negative or strange numbers if Hours or Calendar Period are empty .

Basically if I delete a Task and the associated periodicity, hours or days, the rest of the row blanks out. If you look at CD11 first row, there is an exhaust inspection in faint text which occurred when I deleted the rest of the row. Really when I delete the Task, the coloured cell in column "D" should lose any colour. File attached for your perusal.

Sample blank check formula. Subtime is a sub for time calculations.

Code:

---

=IF(C11 <> "",subtime($E$5,E11),"")

---

Current PriorityColores List

Code:

---

Public Enum PriorityColors    'Resulting Color in Comments
    'Set = to selected Color Picker Index number
    clrPriority0 = -4142
    clrPriority1 = 1 'Black
    clrPriority2 = 37 'A blue
    clrPriority3 = 4 'A Green
    clrPriority4 = 40 'an orangey color
    clrPriority5 = 3 'Red
   
End Enum

---

Just found part of my mistake. Font.ColorIndex. Duhhh:banghead:

Code:

---

Public Sub SetColors(sht As Worksheet, Cel As Range)   
    Dim TimePriority As Long
    Dim TimeColor As Long
    Dim DatePriority As Long
    Dim DateColor As Long
    Dim TaskColor As Long
    Dim TaskPriority As Long
    Dim Rw As Long
    Dim i As Long
   
    With sht
        Rw = Cel.Row
        TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
        DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol)) '<<<Changed from your Sheet Code!!!!
       
        TimeColor = ColorByPriority(TimePriority)
        DateColor = ColorByPriority(DatePriority)
        TaskColor = TimeColor
        If TimePriority < DatePriority Then TaskColor = DateColor
       
        With .Cells(Rw, TaskCol).Font
            .Color = TaskColor
            .Bold = False
            If TaskPriority >= Priority5 Then .Bold = True
        End With
       
        .Cells(Rw, BLankCol1).Interior.ColorIndex = TaskColor 'Adjust to suit
       
       
        ColoredHoursCells = Array("G", "I")
        For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
            .Rows(Rw).Columns(ColoredHoursCells(i)).Font.ColorIndex = TimeColor
        Next i
       
       
       
        ColoredDaysCells = Array("N", "O")
        For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
            .Rows(Rw).Columns(ColoredDaysCells(i)).Font.ColorIndex = DateColor
        Next i
    End With
End Sub

---

And I've just found for the Task column font colour.
Bold is not working for <=0 , so thats my next issue!

Code:

---

With .Cells(Rw, TaskCol).Font.ColorIndex = TaskColor
            .Bold = False

            If TaskPriority >= Priority5 Then .Bold = True

        End With

---

If your font is normally black, why do you need to have a color "Black?" -4105, the automatic color, will set the font to black. I am not sure that the Font object will accept -4142 as an option. It might, but it doesn't look like it from your sheets.

Quote:

---

Basically if I delete a Task and the associated periodicity, hours or days, the rest of the row blanks out.

---

You didn't delete the task, but I know what you mean. I am assuming that that row should just go to unformatted with color.

You added Case Else: PriorityDays = Priority0 to the Priority (Days and Horus) subs, but there is no Else so that is never reached. Priorty0 is only ever assigned when the Cel.Value is "". Also, as long as a ColorIndex of 1 (Black) can be assigned, you will have black cells.

When you tested my submitted code, as I wrote it, what were the results?

I was going to simplify the code in Main, but you've changed things and I don't know what you are doing with it.

Your attachment is so protected that I can't work with it to see what is going on. It is also READ ONLY, and I am not going thru that hassle again. This is a development book and should not be protected, read only, or have any active "On Err GoTo"s or "DisplayAlerts = False" in it. Any attribute that prevents the programmer from seeing everything that is happening and/or keeps him from doing anything she wants to a WIP should not be set.

Go back to the book you were using before my last code submission. Add and edit the code as in my submission. Unprotect all cells and all sheets. Save the book, but NOT as Read Only. Close and reopen the book. Test the book. Note any failures, and, if any errors the sub and line they occur on. Upload the book here without any other edits to the code.

Ok SamT,

Please see if this doesn't cause you any grief. Hopefully its not Read Only now: pray2:

I believe I've followed your instructions as advised with the changes you posted both in code and instructions.

Cheers

I told you not to look. :D

Well at least I'm learning........albeit veeeeery slooowly:rotlaugh:

SamT will be gone for a while

If you need more help, start another thread and reference this on in it. That will get more people working on it. Sorry.