Background colour of cells to change based on value.

[KyleJackMorrison]

Hello,

I have a document (shared) which we use as a calendar and to keep track of people and where they are. It has all 365 day on it and with over 100 people.
I would like a vba to search the document and change the cell colour based on the value. For example: Red if someone is away on holiday. Green if they are on a course.

I use conditional formatting however as people copy and paste in the document, it copies the conditional formation stuff which now has rendered the document unworkable as it crashes due to too many conditional formatting rules.

I have also tried a simple code which colours the cells based on a value, however if someone types "holiday" or "HOLIDAY" it wont change the colour due to the code only searching for "Holiday" in ProperCase.

Is there a more efficient way of having a code where i don't have to put in every type of case search criteria which will slow down the sheet.

Many thanks in advance!

(Current code im using)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myRange As Range
Dim myCell As Range
Set myRange = Range("G5:NL104")
    For Each myCell In myRange
    If InStr(1, (myCell.Value), "Leave") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    For Each myCell In myRange
    If InStr(1, (myCell.Value), "LEAVE") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    For Each myCell In myRange
    If InStr(1, (myCell.Value), "leave") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    For Each myCell In myRange
    If InStr(1, (myCell.Value), "Holiday") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    For Each myCell In myRange
    If InStr(1, (myCell.Value), "HOLIDAY") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    For Each myCell In myRange
    If InStr(1, (myCell.Value), "holiday") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If




Next myCell
End Sub

 

[mrshl9898]

Ucase will cut down the search a bit:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim myRange As Range
Dim myCell As Range


Dim myRange As Range
Dim myCell As Range


Set myRange = Range("G5:NL104")
    For Each myCell In myRange
    If InStr(1, UCase(myCell.Value), "LEAVE") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    If InStr(1, UCase(myCell.Value), "HOLIDAY") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If


Next myCell
End Sub


Next myCell
End Sub

Can use OR if the cell colors are the same too.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim myRange As Range
Dim myCell As Range


Set myRange = Range("G5:NL104")
    For Each myCell In myRange
    If InStr(1, UCase(myCell.Value), "LEAVE") > 0 Or InStr(1, UCase(myCell.Value), "HOLIDAY") Then
    myCell.Interior.ColorIndex = 6
    End If


Next myCell
End Sub

 

[KyleJackMorrison]

Hey, thanks for that @mrshl9898.

I've managed to put everything into my sheet when using your formula that worked fantastic. However i have a large area and alot of colour/things to search so when i edit a cell it takes about a second or two to run the script complete.
Is there a more efficient way or a way to recommend to help improve this script?

Private Sub Worksheet_Change(ByVal Target As Range)Dim myRange As Range
Dim myCell As Range
Set myRange = Range("I6:NN105")
For Each myCell In myRange
Application.EnableEvents = False
    'Colorindex = 3 - Leave
    If InStr(1, UCase(myCell.Value), "LEAVE") > 0 Then
    myCell.Interior.ColorIndex = 3
    End If
    'Colorindex = 6 - Guard
    If InStr(1, UCase(myCell.Value), "GUARD") > 0 Or InStr(1, UCase(myCell.Value), "DJNCO") > 0 Or _
    InStr(1, UCase(myCell.Value), "DSNCO") > 0 Or InStr(1, UCase(myCell.Value), "ROS") > 0 Or _
    InStr(1, UCase(myCell.Value), "QRF") > 0 Or InStr(1, UCase(myCell.Value), "GD COM") > 0 Or _
    InStr(1, UCase(myCell.Value), "DUTY") > 0 Then
    myCell.Interior.ColorIndex = 6
    End If
    'ColorIndex = 10 - Exercise
    If InStr(1, UCase(myCell.Value), "EXERCISE") > 0 Or InStr(1, UCase(myCell.Value), "EX ") > 0 Then
    myCell.Interior.ColorIndex = 10
    End If
    'ColourIndex = 16 - Operations
    If InStr(1, UCase(myCell.Value), "OP ") > 0 Or InStr(1, UCase(myCell.Value), "OPERATIONS ") > 0 Then
    myCell.Interior.ColorIndex = 16
    End If
    'ColourIndex = 41 - Events
    If InStr(1, UCase(myCell.Value), "EVENT ") > 0 Or InStr(1, UCase(myCell.Value), "EVENTS ") > 0 Then
    myCell.Interior.ColorIndex = 41
    End If
    'ColourIndex = 4 - Military Training
    If InStr(1, UCase(myCell.Value), "MIL TRG ") > 0 Or InStr(1, UCase(myCell.Value), "MILITARY TRAINING ") > 0 Or _
    InStr(1, UCase(myCell.Value), "MILITARY TRG ") > 0 Then
    myCell.Interior.ColorIndex = 4
    End If
    'ColourIndex = 7 - Sqn Events
    If InStr(1, UCase(myCell.Value), "SQN EVENT ") > 0 Or InStr(1, UCase(myCell.Value), "SQN EVENTS ") > 0 Then
    myCell.Interior.ColorIndex = 7
    End If
    'ColourIndex = 33 - Appointments
    If InStr(1, UCase(myCell.Value), "APPT ") > 0 Or InStr(1, UCase(myCell.Value), "APP ") > 0 Or _
    InStr(1, UCase(myCell.Value), "APPOINTMENT ") > 0 Then
    myCell.Interior.ColorIndex = 33
    End If
    'ColourIndex = 37 - AT/Sport
    If InStr(1, UCase(myCell.Value), "AT ") > 0 Or InStr(1, UCase(myCell.Value), "SPORT ") > 0 Or _
    InStr(1, UCase(myCell.Value), "SPORT") > 0 Then
    myCell.Interior.ColorIndex = 37
    End If
    'ColourIndex = 46 - Course
    If InStr(1, UCase(myCell.Value), "COURSE ") > 0 Or InStr(1, UCase(myCell.Value), "COURSE") > 0 Then
    myCell.Interior.ColorIndex = 46
    End If
    'ColourIndex = 39 - Placement
    If InStr(1, UCase(myCell.Value), "PLACEMENT ") > 0 Or InStr(1, UCase(myCell.Value), "PLACEMENT") > 0 Then
    myCell.Interior.ColorIndex = 39
    End If
    'ColourIndex = 53 - Bulldogs
    If InStr(1, UCase(myCell.Value), "BD") > 0 Or InStr(1, UCase(myCell.Value), "BULLDOG") > 0 Then
    myCell.Interior.ColorIndex = 46
    End If
    'ColourIndex = 52 - Platform
    If InStr(1, UCase(myCell.Value), "PLATFORM") > 0 Then
    myCell.Interior.ColorIndex = 53
    End If
    'ColourIndex = 1 - Posted
    If InStr(1, UCase(myCell.Value), "POSTED") > 0 Or InStr(1, UCase(myCell.Value), "OFF STRENGTH") > 0 Then
    myCell.Interior.ColorIndex = 1
    myCell.Font.Color = vbWhite
End If
Next myCell
Application.EnableEvents = True
End Sub

 

[My Aswer Is This]

Here is a example of how you can do it.
Notice:
Option Compare Text

At top of script.

Now how many different values might you need to search for. I provide Leave and Holiday.

Do you have one or two more or dozens more?

This script runs when you make a change manually to any value in column A

It only modifies the value in the current row

Try this:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  10/16/2018  3:40:19 PM  EDT
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target.Value = "Leave" Or Target.Value = "Holiday" Then Target.Interior.ColorIndex = 6
End If
End Sub

 

[My Aswer Is This]

Or try this:

Add more as you want:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  10/16/2018  3:56:19 PM  EDT
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
With Target.Interior
Select Case Target.Value
Case "Leave", "Holiday"
.ColorIndex = 3
Case "Me", "You", "Us", "They"
.ColorIndex = 8
Case "Her", "Him", "Them"
.ColorIndex = 5


End Select
End With

End If
End Sub

 

[My Aswer Is This]

I now notice you had a particular Range.
Your last range was this:

Try this:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  10/16/2018  3:56:19 PM  EDT
If Not Intersect(Target, Range("I6:NN105")) Is Nothing Then
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
With Target.Interior
Select Case Target.Value
Case "Leave", "Holiday"
.ColorIndex = 3
Case "Me", "You", "Us", "They"
.ColorIndex = 8
Case "Her", "Him", "Them"
.ColorIndex = 5


End Select
End With

End If
End Sub

 

[KyleJackMorrison]

@My Aswer Is This

As usual, outstanding and fast working script.
One problem, if I delete the the word it has a "Runtime error 13, Type Mismatch." Help on getting that to be fixed?
Many thanks

 

[My Aswer Is This]

Which of my scripts are you using?
If your using the last one then when I clear the cell I get no error.
Define Delete.
Do you mean you had Dad in the cell and now you press delete which only clears the cell value

Or do you mean you select the cell then actually delete the cell by right clicking and choose delete.

 

[KyleJackMorrison]

The last script.
And I've just realised it's only when i have a merged cell called "leave" and then select and press delete on the keyboard.

 

[My Aswer Is This]

Yes if you have been on this forum for long. You will see most people say using merged cells can cause you problems. When using Vba.

Now I merged some cells and I did not get any error
Do you have any other sheet change event scripts in your sheet.

Here try this:

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
'Modified  10/16/2018  4:56:19 PM  EDT
If Not Intersect(Target, Range("I6:NN105")) Is Nothing Then
On Error GoTo M
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
With Target.Interior
Select Case Target.Value
Case "Leave", "Holiday"
.ColorIndex = 3
Case "Me", "You", "Us", "They"
.ColorIndex = 8
Case "Her", "Him", "Them"
.ColorIndex = 5


End Select
End With
Exit Sub
M:
MsgBox "Bad Boy using merged cells again?"
End If

End Sub