PDA

View Full Version : [SOLVED] Colour Entire Row Base on the Value of Two Other Cells



mexmike
06-27-2015, 02:08 PM
Hi,
I'm having problems with conditional formatting. Conditional Formatting using the built in Excel formatting seems to require very long formulas for what I wish to achieve. I was hoping to get help coding with VBA instead.
I have attached a more exact example of my problem. Basically I want to colour each row based on the values in row "G" and "O'. They can be Red, Green, Blue or Black.
13806
Below is my Excel Conditional Format effort for most of the conditions but does not include the ISBLANK in most cases. I am hoping that VBA will be simpler.


=IF(AND(ISBLANK($G$11),ISBLANK($O$11)),TRUE,FALSE)
=IF(AND(($G$11<=20),ISBLANK($O$11)),TRUE,FALSE)
=IF(AND(AND(($G$11>20),( $G$11<=50)),ISBLANK($O$11)),TRUE,FALSE)
=IF(AND(AND(($G$11>50),( $G$11<=100)),ISBLANK($O$11)),TRUE,FALSE)
=IF(AND(AND(($G$11>100)),ISBLANK($O$11)),TRUE,FALSE)
=IF(AND(ISBLANK($G$11),( $O$11<=7)),TRUE,FALSE)
=IF(AND(($G$11<=20),( $O$11<=7)),TRUE,FALSE)
=IF(AND($G$11>20, $G$11<=50, $O$11<=7),TRUE,FALSE)
=IF(AND($G$11>50, $G$11<=100, $O$11<=7),TRUE,FALSE)
=IF(AND($G$11>100, $O$11<=7),TRUE,FALSE)
=IF(AND(ISBLANK($G$11),( $O$11>7), $O$11<=30),TRUE,FALSE)
=IF(AND($G$11<=20, $O$11>7, $O$11<=30),TRUE,FALSE)
=IF(AND($G$11>20, $G$11<=50, $O$11<=30),TRUE,FALSE)
=IF(AND($G$11>50, $G$11<=100, $O$11>7, $O$11<=30),TRUE,FALSE)
=IF(AND($G$11>100, $O$11>7, $O$11<=30),TRUE,FALSE)
=IF(AND(ISBLANK($G$11),( $O$11>30), $O$11<=60),TRUE,FALSE)
=IF(AND($G$11<=20,$O$11>30, $O$11<=60),TRUE,FALSE)***
=IF(AND($G$11>20, $G$11<=50, $O$11>30, $O$11<=60),TRUE,FALSE)
=IF(AND($G$11>50, $G$11<=100, $O$11>30, $O$11<=60),TRUE,FALSE)
=IF(AND($G$11>100, $O$11>30, $O$11<=60),TRUE,FALSE)
=IF(AND(ISBLANK($G$11),( $O$11>60)),TRUE,FALSE)
=IF(AND(($G$11<=20),( $O$11>60)),TRUE,FALSE)
=IF(AND($G$11>20, $G$11<=50, $O$11>60),TRUE,FALSE)
=IF(AND(($G$11>100),( $O$11>60)),TRUE,FALSE)
=IF(AND($G$11>50, $G$11<=100, $O$11>60),TRUE,FALSE)


The columns with "TRUE" or "FALSE", only represent the formulas that I would use for the formatting. In reality they would be TASK's i.e. "Replace Oil Filter"

Many Thanks in Advance

Aussiebear
06-27-2015, 05:51 PM
If you were to attach a workbook, I'm sure it would be a whole lot easier for members to understand the concept. At the moment you have 25 IF statements and no indication of which cells they apply too.

mexmike
06-27-2015, 06:20 PM
Sorry, i didn't realise I could upload an Excel file. That's why there was only an image in my last post. I hope this attached file helps to explain my problem.
I realise the code I have posted is for the Excel Conditional Formatting and would really prefer to go to VBA if possible.

Thanks for any help in advance.

Aussiebear
06-27-2015, 11:28 PM
I'm still struggling to follow the logic of the data you have provided. One of the guidelines in your workbook suggests that you are seeking to colour a target line based on the amount of time left to complete a task, yet it somewhat difficult to work within the data.

For example, What's the relationship between the Days and Hours data? Within the first few rows you have nil days but 20 hrs = Red, 21 hrs = Green, 100 hrs = Blue, & 101 hrs = Black If everything was converted to hours then a simple Case Select could be used.

Next example, a few rows further down all have 7 days allocated but the hours vary between blank & 101hrs. Which is the more determine data?

If this was my worksheet, I'd convert all time (Days & Hours) to one common format, then I have an auto sort each time the workbook was opened, ranking all tasks from minimum to maximum time frames. At the moment this is far more complicated than necessary

SamT
06-28-2015, 07:14 AM
Correct this please.



Hours=0,Days=0
BLACK


Hours<=20,Days=0

RED


Hours>20, <=50,Days=0
GREEN


Hours>50, <=100,Days=0
BLUE


Hours>100,Days=0
BLACK


Hours=0, Days<=7
RED


Hours<=20, Days<=7
RED


Hours>20, <=50, Days<=7
RED


Hours>50, <=100, Days<=7
RED


Hours>100, Days<=7
RED


Hours=0, Days>7,<=30
GREEN


Hours<=20, Days>7,<=30
RED


Hours>20, <=50, Days>7,<=30



Hours>50, <=100, Days>7,<=30
GREEN


Hours>100, Days>7,<=30
GREEN


Hours=0, Days>30,<=60
BLUE


Hours<=20,Days>30, <=60
RED


Hours>20, <=50, Days>30,<=60
GREEN


Hours>50, <=100, Days>30,<=60
BLUE


Hours>100, Days>30,<=60
BLUE


Hours=0, Days>60
BLACK


Hours<=20, Days>60
RED


Hours>20, <=50, Days>60
GREEN


Hours>50, <=100, Days>60
BLUE


Hours>100, Days>60
BLACK






Select Case Hours + (Days * 24)
Case 0: Tint = Black
Etc
End Select
Cell.Interior.Color = Tint

snb
06-28-2015, 09:28 AM
A CF formula can't look like:


=IF(AND(ISBLANK($G$11),ISBLANK($O$11)),TRUE,FALSE)
but only

=AND(ISBLANK($G$11),ISBLANK($O$11))

mexmike
06-28-2015, 12:09 PM
Hi and thanks for the kind help.

I've uploaded a modified spreadsheet that will hopefully explain what I'm trying, rather in vain, to achieve.

There are comments above the Columns which may clarify things. You will see that the only important Columns are the TASK column "A" , the HOURS column "G" and the DAYS column "O". All the other columns are to help me understand where I am and try to get my head around the problem. An important point to note is that HOURS are "running hours" not calendar hours.

snb.
Thanks for correcting my incorrect CF formula. I really do not want to use CF in Excel but rather VBA. The CF formulas where my first attempt at resolving my problem but I soon started to get lost when trying to apply them. If you change any of the values in the sample date HOURS or DAYS column, the cells do change TRUE and FALSE.

I hope this brings a little more clarity to my request.
Thanks again.

SamT
06-28-2015, 12:57 PM
In your latest book, the colors of the tasks are not dependent on hours or days, (See A21, A26)

You have positive hours and negative Days. WTF? (see A16, A21, )

Your notes say that these are hours and days " Remaining to the associated TASK." But you have a situation (Row 12) where the task is 100 hours overdue, but there are 60 days remaining. On the other hand (Row 21) the task has 21 hours remaining, even though it is 2 days overdue.

But at least now we can see that there are two sets of color rules



Hours IsEmpty
Black


Hours<=20
Red


Hours<=50
Green


Hours <=100
Blue


Else (> 100)
Black





Days IsEmpty
Black


Days <= 7
Red


Days <=30
Green


Days <=60
Blue


Else (>60)
Black




Since you want the Task colored according the which time frame has the highest priority (Days = 5 is higher priority than hours = 21)

Is that right? I won't continue coding until I know.

Why not use 24 hour ranges for the hours, ie, 24, 48, and 96, instead of 20, 50, and 100?

p45cal
06-28-2015, 01:31 PM
cross posted very similar/same at:
http://www.ozgrid.com/forum/showthread.php?t=195358&page=2
http://www.excelguru.ca/forums/showthread.php?4632-VBA-for-Excel-Conditional-Format-Font-Color-Entire-Row-Based-on-Value-in-Two-Columns

mexmike
06-28-2015, 02:40 PM
Hi SamT, Logic for my Colours are as follows:

HOURS
RED <=20 Less than or equal to 20
GREEN >20<=50 Greater than 20 and less than or equal to 50
BLUE >50<=100 Greater than 50 and less than or equal to 100
BLACK >100 Greater than 100
BLACK ISEMPTY just for logic

DAYS
RED <=7 Less than or equal to 7
GREEN >7<=30 Greater than 7 and less than or equal to 30
BLUE >30<=60 Greater than 30 and less than or equal to 60
BLACK >60 Greater than 60
BLACK ISEMPTY just for logic.

I plan to Autofilter tasks based on HOURS and then tasks based on DAYS to help me decide which order to carry out work.

HOURS (running hours not calendar. If the vehicle is not in use no hours accumulated)

Negative numbers indicates a vehicle has missed an inspection and run over either running hours or calendar date because the operator didn't bring it in for maintenance due to negligence or the maintainer did not pay attention to this spreadsheet.

Some tasks have both running time and calendar limits. The important thing is that an inspection that has just gone RED will fall soon, even though the same task based on calendar may be BLUE and not yet due. It's a case of whichever comes first, hours running time or days.

I hope this helps explain and many thanks for your time.

mexmike
06-28-2015, 02:46 PM
Please excuse my ignorance regarding cross posting. I guess I have not read posting rules thoroughly enough.

SamT
06-28-2015, 04:46 PM
Now it makes sense. Do you want Tasks, Hours and Days colored?

mexmike
06-28-2015, 05:03 PM
Hi SamT,
It would be great if that was possible. I would colour each according to their current status.
Thanks for the assistance.

SamT
06-28-2015, 08:13 PM
The Functions in Module1 are pretty generic, they don't care where the cell is. I set up the code structure so that it is easy to add a priority level, if, for instance, you decide that what is red should be yellow and negative numbers should be Red.

The code in sheet1:

If you ever change the layout of your Tasks sheet, be sure that the Constants at the top of the code match the new column layout.

The Worksheet_change Sub: If you don't understand the comments, ask, I am not always clear in my instructions.

The SetColors Sub: It works, should'nt need to mess with it. Except, I added a fillip at the very bottom to set the Font in the Tasks Column to Bold, if it was Red. You can't miss it. If you don't like it, just comment out that IF...Then line.

The SetColorsManually Sub is only needed when your Tasks sheet has never had it's colors set or when the whole thing needs updating. To run it, place the mouse cursor inside the sub and press F5.

Module1 Code
Option Explicit

Enum Priorities
Priority0
Priority1
Priority2
Priority3
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 <= 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 <= 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 0: ColorByPriority = vbBlack
Case 1: ColorByPriority = vbBlue
Case 2: ColorByPriority = vbGreen
Case 3: ColorByPriority = vbRed
End Select
End Function

Sheet1 Code
Option Explicit

'Edit all to suit
Const TaskCol As Long = 1
Const HoursCol As Long = 7
Const DaysCol As Long = 15




Private Sub Worksheet_Change(ByVal Target As Range)
Dim TrackChanges As Range

'TrackChanges must be set to those ranges that are manually changed.
'If the values in Days and Hours Remaining are the result of formulas, then
'define these ranges as the locations where the new values of the
'formula precedents are entered
Set TrackChanges = Range(Range(Cells(11, TaskCol), Cells(10000, TaskCol)). _
Range(Cells(11, HoursCol), Cells(10000, HoursCol)), _
Range(Cells(11, DaysCol), Cells(10000, DaysCol)))
If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

SetColors Target

End Sub


Private Sub SetColors(Cel As Range)
Dim TimePriority As Long
Dim DatePriority As Long
Dim TaskPriority As Long
Dim Rw As Long

Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursCol))
Cells(Rw, HoursCol).Font.Color = ColorByPriority(TimePriority)

DatePriority = PriorityHours(Cells(Rw, DaysCol))
Cells(Rw, DaysCol).Font.Color = ColorByPriority(DatePriority)

If DatePriority > TimePriority Then
TaskPriority = DatePriority
Else
TaskPriority = TimePriority
End If

With Cells(Rw, TaskCol).Font
.Color = ColorByPriority(TaskPriority)
.Bold = False
If TaskPriority = Priority3 Then .Bold = True
End With

End Sub





'Run once to set all tasks
Private Sub SetColorsManually()
Dim Cel As Range
For Each Cel In Range("A11:A" & Cells(Rows.Count, 1).End(xlUp).Row)
SetColors Cel
Next Cel
End Sub

snb
06-29-2015, 12:54 AM
I'd use:

Daypriority


="priority "&CHOOSE(MATCH(INT(TODAY()-A12);{-1;0;7;30;60;90};1);"red";"orange";"blue";"green";"yellow";"black")

Hourpriority

"hourpriority "&choose(MATCH(24*(C1-MOD(NOW();1));{-1;0;20;50;100;120};1);"red";"orange";"blue";"green";"yellow";"black")

mexmike
06-29-2015, 05:16 AM
Dear SamT,

Amazing work. I'm quite speechless at your effort. Cleary I would have spent the next half century trying to achieve this result.

Many many thanks.

Snb, Many thanks also for your input, now that have an idea of what's involved, I'll try your suggestions as well.

Once again. Many many thanks to all. Very inspiring and extremely educational.

Kind Regards.

mexmike
06-29-2015, 02:39 PM
Hi SamT and snb,

I followed your advice regarding the negative numbers by adding a Case; worked a treat!
Also, I changed from the vbgreen to
Case 2: ColorByPriority = RGB(32, 148, 68) as the vbgreen colour is a little too bright.

I had integrated your code into my working spreadsheets, which are way more complex than my example spreadsheet, expecting trouble as they already have VBA code. Guess what not a single problem. Everything worked exactly as advertised. Also, as you quite rightly state, it is quite universal and can be applied to a wide range of spreadsheets not just my application.

Great work, really! I owe you a beer or three when you next come through Trinidad where I'm based.

SamT
06-29-2015, 03:32 PM
:beerchug:

mexmike
06-29-2015, 04:00 PM
Thanks for offering to clarify comments that you made in your coding.

Regarding this; I do use formulas to calculate hours and days remaining but do not understand, due to ignorance'...
"If the values in Days and Hours Remaining are the result of formulas, then'define these ranges as the locations where the new values of the formula precedents are entered".
My Days remaining formula, is based on a cell with
=NOW(), periodicity in days and date last completed.
HOURS remaining comes from a formula based on single cell with current total vehicle hours, hours at which an inspection was completed and periodicity at which an inspection occurs i.e. Oil change 200 Hours, done at 789 hours. I update the total vehicle hours each day and of course, the calendar rolls by on it's own, so no need to input the date each day.


Also, my TASKS are selected from a drop down list on each row "A". Once I pick a new task and add periodicity for HOURS and DAYS, and hours and date completed at etc , I'd like the individual row colours to update at that time if possible.

These final details would allow me to not go into VBA to update the colours as new TASKS are entered onto the sheet.

Once again thank you for your kind assistance.

SamT
06-29-2015, 05:52 PM
This is the code where the procedure is Triggered


Set TrackChanges = Range(Range(Cells(11, TaskCol), Cells(10000, TaskCol)), _
Range(Cells(11, HoursCol), Cells(10000, HoursCol)), _
Range(Cells(11, DaysCol), Cells(10000, DaysCol)))
If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

Taking it line by line
the first part "Set TrackChanges = Range" is the Assignment.

This line defines the range that is the top 10000 rows of column A, (Column number 1.) Note that it is a Range from one Cell to the next. The Space Underscore at the end is the Line Continuation code.

(Range(Cells(11, TaskCol), Cells(10000, TaskCol)), _
The next Line Defines the Hours column. Like all three Range definitions, it uses predefined Constants for the column Number. You can use the Column Letter(s) String in place of the Column Number. (Cells(11, "H"),) Using the Column Number is just my style. The third line is the same for the Days column

Range(Cells(11, HoursCol), Cells(10000, HoursCol)), _
the final line say that if the changed cell was not in the Defined Range "TrackChanges," then Don't run the sub anymore.

If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

Right now the Procedure will only be run when you add a new Task, which is before the Remaining Days and hours are present. Not good.

Once I ... add periodicity for HOURS and DAYS, and hours and date completed at etc , I'd like the individual row colours to update at ... [those Events] if possible.
I anticipated this, that is why the Sub SetColors only uses the Cell Row. Any Cell can be used as a trigger as long as it is in the same Row as the Task. At different times you will be making two changes at the same time. This will trigger the procedure at each change. The "EnableEvnts" mentioned in some code below will keep this from being a problem.

In the Sheet Code:
Remove these lines

'Edit all to suit
Const TaskCol As Long = 1
Const HoursCol As Long = 7
Const DaysCol As Long = 15
and Replace them with these. Put the appropriate column letters in between the quote marks.

'edit all to suit
Const HoursPeriodCol As String = ""
Const DaysPeriodCol As String = ""
Const TimeCompleteCol As String = ""
Const DateCompleteCol As String = ""

In the Worksheet_change sub, Replace these lines"

Set TrackChanges = Range(Range(Cells(11, TaskCol), Cells(10000, TaskCol)), _
Range(Cells(11, HoursCol), Cells(10000, HoursCol)), _
Range(Cells(11, DaysCol), Cells(10000, DaysCol)))
If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

SetColors Target

With these lines. If you get errorrs, first look for typos. I am famuose for them.

Set TrackChanges = Range(Range(Cells(11, DaysPeriodCol), Cells(10000, DaysPeriodCol)). _
Range(Cells(11, HoursPeriodCol), Cells(10000, HoursPeriodCol)), _
Range(Cells(11, TimeCompleteCol), Cells(10000, TimeCompleteCol)), _
Range(Cells(11, DateCompleteCol), Cells(10000, dateCompleteCol)))

If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

Application.EnableEvents = False
SetColors Target
Application.EnableEvents = True

These changes means that the procedure will no longer change when you change a task. But then it doesn't need to, does it?

mexmike
06-29-2015, 06:53 PM
Ok, done but I'm getting Compile error. "Wrong number of arguments or invalid property assignment" at the bolded Range as below. spelling looks good.



Option Explicit

'edit all to suit
Const HoursPeriodCol As String = "C"
Const DaysPeriodCol As String = "L"
Const TimeCompleteCol As String = "E"
Const DateCompleteCol As String = "M"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TrackChanges As Range


'TrackChanges must be set to those ranges that are manually changed.
'If the values in Days and Hours Remaining are the result of formulas, then
'define these ranges as the locations where the new values of the
'formula precedents are entered


Set TrackChanges = Range(Range(Cells(11, DaysPeriodCol), Cells(10000, DaysPeriodCol)). _
Range(Cells(11, HoursPeriodCol), Cells(10000, HoursPeriodCol)), _
Range(Cells(11, TimeCompleteCol), Cells(10000, TimeCompleteCol)), _
Range(Cells(11, DateCompleteCol), Cells(10000, DateCompleteCol)))

If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

Application.EnableEvents = False
SetColors Target
Application.EnableEvents = True



End Sub

SamT
06-29-2015, 07:22 PM
see that dot near the end of the first line. That is some artifact of the forum. I have removed it several times and replaced it with a comma, but it just keeps coming back.

In your workbook, replace that dot with a comma.

snb
06-30-2015, 12:19 AM
The CF approach:

mexmike
06-30-2015, 05:07 AM
Gooday SamT,

I have replaced the "." with the "," as recommended but still get the same error at the first Range in...
Set TrackChanges = Range(Range

My sheet code is as follows. Note there is a password unprotect statement in it (password removed)...


Option Explicit

'Edit all to suit
Const HoursPeriodCol As String = "C"
Const DaysPeriodCol As String = "L"
Const TimeCompleteCol As String = "E"
Const DateCompleteCol As String = "M"


Private Sub Worksheet_Change(ByVal Target As Range)
Dim TrackChanges As Range

'TrackChanges must be set to those ranges that are manually changed.
'If the values in Days and Hours Remaining are the result of formulas, then
'define these ranges as the locations where the new values of the
'formula precedents are entered
Set TrackChanges = Range(Range(Cells(11, DaysPeriodCol), Cells(10000, DaysPeriodCol)), _
Range(Cells(11, HoursPeriodCol), Cells(10000, HoursPeriodCol)), _
Range(Cells(11, TimeCompleteCol), Cells(10000, TimeCompleteCol)), _
Range(Cells(11, DateCompleteCol), Cells(10000, DateCompleteCol)))

If Intersect(TrackChanges, Target) Is Nothing Then Exit Sub

Application.EnableEvents = False
SetColors Target
Application.EnableEvents = True



End Sub

Private Sub SetColors(Cel As Range)
Dim TimePriority As Long
Dim DatePriority As Long
Dim TaskPriority As Long
Dim Rw As Long


Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursCol))
Cells(Rw, HoursCol).Font.Color = ColorByPriority(TimePriority)

DatePriority = PriorityHours(Cells(Rw, DaysCol))
Cells(Rw, DaysCol).Font.Color = ColorByPriority(DatePriority)

If DatePriority > TimePriority Then
TaskPriority = DatePriority
Else
TaskPriority = TimePriority
End If

With Cells(Rw, TaskCol).Font
.Color = ColorByPriority(TaskPriority)
.Bold = False
If TaskPriority = Priority3 Then .Bold = True
If TaskPriority = Priority4 Then .Bold = True


End With

End Sub

'Run once to set all tasks
Private Sub SetColorsManually()
ActiveSheet.Unprotect Password:=""
Dim Cel As Range
For Each Cel In Range("A11:A" & Cells(Rows.Count, 1).End(xlUp).Row)
SetColors Cel
Next Cel
ActiveSheet.Protect Password:=""
End Sub


Thanks

SamT
06-30-2015, 06:22 AM
Have I told you that I hate typing because of typos? Days ago, I made that typo of putting a dot where a comma belonged. That dot hid a language error I made at the same time, and, unfortunately allowed the app to do its job, at least under very restricted circumstances. Obviously it failed when put in production. At least I was forced to get off my lazy butt and figured out what the Help file really meant. I won't make that mistake again

All it takes is to change one word. Where you see "Set TrackChanges = Range," make it "Set TrackChanges = Union."

:banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying::banghead: :crying:

snb
06-30-2015, 06:48 AM
Less chance for typos with:


Set R_1 = Union([C11:C10000], [E11:E10000], [L11:M10000])

mexmike
06-30-2015, 02:24 PM
Hi SamT,

Thanks for your last input. Don't be hard on yourself as your help is always greatly appreciated.

Did the union change but then got a “variable not defined” in snippet... “With Cells(Rw, TaskCol).Font” I redefined TaskCol As Long and it went away.

Now all I need, if possible, is to get the colours to update as data input changes from either myself or from the automatic date calculation i.e. the date calculation comes from Excel, so calendar counts down on its own.

Also, I would like columns “A”, “G”, “I”, “N” & “O” to be colour formatted, as they are the numbers I need to watch as well as the Task itself which also needs to be coloured.

I believe I may have to add the following constants for Hours Due and Days Remaining…

Const TaskCol As Long = 1
Const HoursRemainCol As String ="G"
Const HoursDueCol As String = "I"
Const DateDueCol As String = "N"
Const DaysRemainingCol As String = "O"
Const HoursPeriodCol As String = "C"
Const TimeCompleteCol As String = "E"
Const DaysPeriodCol As String = "L"
Const DateCompleteCol As String = "M"


I also get a variable not defined for "HoursCol". Should this be my new Const HoursRemainCol? or HoursPeriodCol?


Rw = Cel.RowTimePriority = PriorityHours(Cells(Rw, HoursCol))
Cells(Rw, HoursCol).Font.Color = ColorByPriority(TimePriority)


DatePriority = PriorityHours(Cells(Rw, DaysCol))
Cells(Rw, DaysCol).Font.Color = ColorByPriority(DatePriority)

Hope this is not too much of a pain. Phew! so many questions Sorry:banghead:

SamT
06-30-2015, 05:41 PM
That's because I got rid of these lines

Const TaskCol As Long = 1
Const HoursCol As Long = 7
Const DaysCol As Long = 15

TaskCol can be a String = "A" to be consistent with the others
HoursCol = HoursRemaingCol
DaysCol = DaysRemainingCol.

Lets take theExisting SetColors Sub

Private Sub SetColors(Cel As Range)
Dim TimePriority As Long
Dim DatePriority As Long
Dim TaskPriority As Long
Dim Rw As Long

Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursCol))
Cells(Rw, HoursCol).Font.Color = ColorByPriority(TimePriority)

DatePriority = PriorityHours(Cells(Rw, DaysCol))
Cells(Rw, DaysCol).Font.Color = ColorByPriority(DatePriority)

If DatePriority > TimePriority Then
TaskPriority = DatePriority
Else
TaskPriority = TimePriority
End If

With Cells(Rw, TaskCol).Font
.Color = ColorByPriority(TaskPriority)
.Bold = False
If TaskPriority = Priority3 Then .Bold = True
If TaskPriority = Priority4 Then .Bold = True
End With
End Sub
And reorder the lines for clarity and add your new columns

Option Explicit

Const TaskCol As String = "A"
Const HoursPeriodCol As String = "C"
Const TimeCompleteCol As String = "E"
Const HoursRemainCol As String = "G"
Const HoursDueCol As String = "I"

Const DaysPeriodCol As String = "L"
Const DateCompleteCol As String = "M"
Const DateDueCol As String = "N"
Const DaysRemainingCol As String = "O"

Private Sub SetColors(Cel As Range)
Dim TimePriority As Long
Dim DatePriority As Long
Dim TaskPriority As Long
Dim Rw As Long

Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursCol))
DatePriority = PriorityDays(Cells(Rw, DaysCol)) '<<<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 >= Priority3 Then .Bold = True '<<<<Note Change

End With

'IMO, this layout is not only clearer, but I just copied one line 4 times
' and then changed one word in each new line
Cells(Rw, HoursPeriodCol).Font.Color = ColorByPriority(TimePriority)
Cells(Rw, TimeCompleteCol).Font.Color = ColorByPriority(TimePriority)
Cells(Rw, HoursRemainCol).Font.Color = ColorByPriority(TimePriority)
Cells(Rw, HoursDueCol).Font.Color = ColorByPriority(TimePriority)

Cells(Rw, DaysPeriodCol).Font.Color = ColorByPriority(DatePriority)
Cells(Rw, DateCompleteCol).Font.Color = ColorByPriority(DatePriority)
Cells(Rw, DateDueCol).Font.Color = ColorByPriority(DatePriority)
Cells(Rw, DaysRemainingCol).Font.Color = ColorByPriority(DatePriority)
'See Constants above and compare this line to previous 4 lines
'Range ("L" & Rw & ":O" & Rw).Font.Color = ColorByPriority(DatePriority)
'IMO, use the Previous 4 for consistancy with first 4. YMMV

End Sub

mexmike
06-30-2015, 06:44 PM
Ok got that and have just integrated it into my sheet. I left "Set TrackChanges" with the corrections you mentioned and have given it a spin. Seems ok so far. I'll report back tomorrow once given a more thorough testing. my eyes knackered with all the concentration.

Many many thanks and Goodnight Good Knight.:hi:

mexmike
07-01-2015, 12:47 PM
Ok SamT,

That's it! I made a couple of alterarions to get one more column to change colour and everything is still tickety boo!
Your code and explanations have helped me to no end and the code is flexible enough for me to make any minor changes that I might need to make in the future.

That said, although I dont' undestand all of the code you kindly worked on, I've learnt a lot and will hopefully be more self sufficient VBA wise.

Cheers and Thanks again to you and all at VBAX.

mexmike
07-02-2015, 05:29 PM
Morning SamT,

Just come across a minor glitch which I hadn't noticed; Sorry!!!

I've just this morning opened up the spreadsheet and noticed that although the actual date has changed (all calendar items depend on this),
=NOW()the colour of Days DaysRemainingCol and their related cells that also should have changed colour, are still the previous days colour, i.e. have not counted down in colour. So instead of having changed from yellow to red as the date rolled over from yesterday, they are still yellow. Everything else changes as advertised If I make an input change in that row.

The same pretty much applies to "vehicle hours" (all hour items depend on this), such that all the inspection tasks recalculate in the HoursRemainingCol. Their cells also do not automatically change colour unless I make a change in that row. My fault for not mentioning this when I first asked for help.:(

In each case, date and hours, all other calculations refer to these respective cells for carrying out the HoursRemainingCol and DaysRemainingCol calculations. Can you let me know how to include that into the code?

I think I may need to use something like...


Private Sub Worksheet_Calculate()

Dim target As Range

Set target = Range("E5")


If Not Intersect(target, Range("E5")) Is Nothing Then Exit Sub

Application.EnableEvents = False
SetColors target
Application.EnableEvents = True

End Sub


That does not appear to work though ("E5" is main hours). Also, I need to refer to cell "A4" =Now() as well, so am still stuck.
Hope you get my drift and as always thanks for the kind help.:bug:

SamT
07-02-2015, 08:51 PM
These additions will update the colors when the workbook is opened and every hour 10 seconds after the hour until you close the book.

ThisWorkbook Code

Option Explicit

Private Sub Workbook_Open()
RunForceUpdateColorsAgain = True
ForceUpdateColors

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
RunForceUpdateColorsAgain = False
ForceUpdateColors

End Sub



Module1 code
Add these lines under the End Enum

Dim RunForceUpdateColorsAgain As Boolean 'Value set in Workbook Open/Close subs
Dim RunForceUptateColorsTime As String

Add these two subs

Sub ForceUpdateColors()

'Initialize time to run
If RunForceUptateColorsTime = "" Then RunForceUptateColorsTime = Time

'Set time to run to next exact hour + 10 seconds
RunForceUptateColorsTime = Format(DateAdd("h", 1, RunForceUptateColorsTime), "h:00:10")

Application.OnTime EarliestTime:=TimeValue(RunForceUptateColorsTime), _
Procedure:="ForceUpdateColors", Schedule:=RunForceUpdateColorsAgain

If RunForceUpdateColorsAgain Then UpdateColors

End Sub

Sub UpdateColors()
Const DateDueCol As String = "N"
Const RopRow As Long = 11
Const TaskSheet As String = "Insert the Tab name of the Worksheet here" '<<<<<<<<<<<<<<<
Dim BottomCell As Range
Dim Temp As Variant
Dim Cel As Range

With Sheets(TaskSheet)
Set BottomCell = Cells(.Rows.Count, DateDueCol).End(xlUp)
For Each Cel In Range(.Cells(TopRow, DateDueCol), BottomCell)
Temp = Cel.Formula
Cel.formula = Temp
DoEvents 'To ensure updating each row.
Next Cel
End With
End Sub

mexmike
07-03-2015, 03:49 PM
Hi SamT,

Sorry, but I need the colour to update each time I introduce the latest main vehicle hours. I have several vehicles and update the hours as soon as new values are known. If for example a lot of hours are accrued, it is important to see what is due immediately. I input the latest vehicle hours and the hours remaining to the next inspection changes immediately. I then open the vehicle tab that needs work and look at the colours of the inspections, as well as hours and days remaining to the next inspections and base the days work on that.

The vehicle hours input sheet only contains the most basic input output data without all the inspection details. The formulas in the individual rows of the inspection sheets calculate the time remaining and then returns the closest inspection due back to the input sheet. This allows me to prioritise which vehicle needs attention at a glance.

I've uploaded a copy of the top sheet where I update the vehicle hours. The current date "=Now()" is taken from this sheet for the date calculations on each vehicle sheet.

As usual many thank for you kind help.

SamT
07-03-2015, 06:45 PM
Please upload the book with all the code in it and a complete schedule sheet. I don't keep any workbooks more than a few days and I haven't seen the changes you made to the code..

To All.

There is a fatal error in the UpdateColors sub above that I just corrected, so if anybody has tried it before now, please look at the new version above.

Sorry for any inconvenience.

mexmike
07-03-2015, 08:58 PM
Ok SamT,

Please see the attached file

I've included all the columns and sample data.

As you'll see, updating the sheet manually works fine but changing the current hours on sheet1 leaves the cell colours unchanged. Same applies as the date automatically rolls over.

As before, thanks for the amazing help:cool:

SamT
07-03-2015, 09:18 PM
I got the attachment, but I am down for the night, C U tomorrow.

mexmike
07-04-2015, 06:34 AM
Please note that there are some gash formulas remaining in sheet2 that I forgot to delete before sending.

Also, you can see by sheet1, that there are normally 5 sheets in total; the input sheet and one for each vehicle.

Very Happy 4th of July to All:bigdance2

mexmike
07-04-2015, 12:23 PM
Just uploaded the workbook with the four vehicle sheets added

mexmike
07-04-2015, 04:02 PM
Hi SamT,

Hope your 4th of July is going swimmingly!

I have added macros to module2 that basically reference the SetColorsManually() sub that you coded for me. Changes to the target cells on sheet1 call that macro. This means the sheets update their colours every time I input vehicle running hours on sheet1, so thats good now.

For the manual row changes on each vehicle sheet, I was hoping to get a single set of code into a module that would cover all of the sheets but have not figured that out yet. So all the sheet code is still in each sheet code module (looks very clumsy but still works).

I still can't seem to get the automatic colour change when the date changes. I tried using your code but get a weird message that I can't remember something about incorrect blah blah!! but the following code gets highlighted if memory serves...

Application.OnTime EarliestTime:=TimeValue(RunForceUptateColorsTime), _
Procedure:="ForceUpdateColors", Schedule:=RunForceUpdateColorsAgain

Boy is it hard to keep track of all the changes but at least it's turning into something usable for me.

Catch you later

mexmike
07-04-2015, 07:08 PM
I've just integrated the previously uploaded sheet with my actual working spreadsheet, which has other macros and formulas. It's like waiting for a kettle to boil for it to get back to the input sheet, after changing vehicle running hours:dunno

SamT
07-04-2015, 08:31 PM
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.

SamT
07-06-2015, 07:42 AM
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.

mexmike
07-06-2015, 02:07 PM
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!!!

mexmike
07-06-2015, 02:37 PM
I thought that the sheets might need activating, so tried the following...


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.

mexmike
07-06-2015, 02:47 PM
just inserted a
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.

mexmike
07-06-2015, 04:55 PM
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?



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

SamT
07-06-2015, 10:55 PM
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

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.

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

mexmike
07-07-2015, 02:25 PM
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...

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.

SamT
07-07-2015, 05:01 PM
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.

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

mexmike
07-07-2015, 05:36 PM
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.

mexmike
07-08-2015, 05:09 AM
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

SamT
07-08-2015, 12:03 PM
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 (http://www.vbaexpress.com/forum/showthread.php?53062-Ontime-vba-opens-another-workbook-that-is-not-requested), It's anopther one with OnTime subs.


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

mexmike
07-08-2015, 02:40 PM
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)
If SecondTime = True Then
2)
Public SecondTime As Boolean
3)
'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
wks.Protect Password:="123", UserInterfaceOnly:=True is present.

mexmike
07-08-2015, 02:57 PM
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...


Temp = Cells(Rw, TaskCol).Formula in the code below


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

SamT
07-08-2015, 02:58 PM
In modCellColoring.SetColors , after coloring the taskcolumn


.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.

mexmike
07-08-2015, 03:08 PM
I inserted an sheet activate and it seems to have done the trick.


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

mexmike
07-08-2015, 04:00 PM
Yes you are right, I have dozens now
My version

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?

SamT
07-08-2015, 05:07 PM
After the "End With"

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"


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 :(

mexmike
07-08-2015, 06:09 PM
Absolutely totally Flabbergasted (https://www.google.tt/url?sa=t&rct=j&q=&esrc=s&source=web&cd=2&ved=0CDcQFjAB&url=http%3A%2F%2Fdictionary.reference.com%2Fbrowse%2Fflabbergasted&ei=CsidVYD2KMaosAXx5Z3IBQ&usg=AFQjCNE9K_JqtcyniXiFhLli5Yx9482sjw&bvm=bv.96952980,d.b2w):clap::clap::clap::friends::friends::friends::friends ::beerchug::beerchug::beerchug::beerchug::beerchug::beerchug::beerchug::bee rchug::beerchug::beerchug::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!

SamT
07-08-2015, 06:31 PM
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.

snb
07-09-2015, 12:57 PM
I couldn't resist the temptation to stick to CF exclusively
I did the main sheet and sheet CD311.

mexmike
07-09-2015, 01:31 PM
Thanks very much snb. I'll take a look.

mexmike
07-09-2015, 03:14 PM
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!!

SamT
07-09-2015, 08:12 PM
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

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

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

mexmike
07-10-2015, 04:32 PM
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...


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



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

SamT
07-10-2015, 07:03 PM
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.

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




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



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

mexmike
07-10-2015, 08:32 PM
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.

SamT
07-10-2015, 10:13 PM
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.

mexmike
07-11-2015, 08:51 AM
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.

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


Current PriorityColores List

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

mexmike
07-11-2015, 09:57 AM
Just found part of my mistake. Font.ColorIndex. Duhhh:banghead:

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

mexmike
07-11-2015, 10:06 AM
And I've just found for the Task column font colour.
Bold is not working for <=0 , so thats my next issue!


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

If TaskPriority >= Priority5 Then .Bold = True

End With

SamT
07-11-2015, 10:32 AM
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.


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.

mexmike
07-11-2015, 12:57 PM
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

SamT
07-11-2015, 01:39 PM
I told you not to look. :D

mexmike
07-11-2015, 03:22 PM
Well at least I'm learning........albeit veeeeery slooowly:rotlaugh:

SamT
07-14-2015, 08:34 AM
SamT will be gone for a while (http://www.vbaexpress.com/forum/showthread.php?53176-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.