Custom coloured cells in Excel
I was given an interesting problem recently. The requirement was for cells in an Excel spreadsheet to be colour coded on the basis of the text in the cell. Also the spreadsheet user needed to be able to maintain the colour coding and the spreadsheet user was an experienced Excel user but had no programming experience.
For example the way it should work is that as the user types, or pastes, into the activity row the cell colour should automatically be set on the basis of the text in the cell, the colour should be removed is what is in the cell does not match any known text.
The text/colour combinations are stored and edited by the user on a separate
The first thing I needed to do is to attach some code to the sheet
This fragment of code is required on each sheet, however this is pretty simple as long as the user just copies an existing sheet.
1 2 3 4 5 6 7 8 9 10 Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Application.ScreenUpdating = False Call Module1.Recolour_Activity_Row(Target) Application.ScreenUpdating = True End Sub
The recolour code simply iterates across all the cells in the passed range, which are all the cells that were changed by typing or pasting passed from the
Worksheet_Change method. As it iterates across the text that is in the changed cells it looks for that text in the named range on the
Reference sheet. If it finds the text it copies the background colour from where it has found a match, otherwise it sets the background colour to
The user only wanted this behaviour to happen on row 2 of the sheet, so we only apply this logic to changed cells on that row.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 Function Get_Activity_Header_Row_Number() As Integer Get_Activity_Header_Row_Number = 2 End Function Function Get_Activities_Range() As Range Set Get_Activities_Range = Worksheets("Reference").Range("activities") End Function Sub Recolour_Activity_Row(ByVal cells As Range) Dim activitiesTable As Range Set activitiesTable = Get_Activities_Range() For Each targetCell In cells If targetCell.row = Get_Activity_Header_Row_Number() Then Set foundActivity = activitiesTable.Find(targetCell.Value, , xlValues, xlWhole) If foundActivity Is Nothing Then targetCell.Interior.ColorIndex = xlColorIndexNone Else targetCell.Interior.Color = foundActivity.Interior.Color End If Set foundActivity = Nothing End If Next Set targetCell = Nothing Set activitiesTable = Nothing End Sub
So all the user has to ensure is that the text only appears once in the reference sheet (only the first one will be used if its there multiple times), and also that the named range encompasses app the cells