Conditional formatting a lot of different colours

[Pigmy]

I have a very large spreadsheet which looks up a number of different other tabs to return the project someone is working on across the day. I'd like to colour the different projects and I could use conditional formatting however there are around 50 different projects and I'd like to find a way of doing that quicker - especially as the end client may want to reorganise the colours!

I had the idea of setting up some form of reference table such as the one below then using a module to colour code them however I became stuck at that point

[TABLE="class: grid, width: 258"]
<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Ref[/TD]
[TD="width: 64"]Colour[/TD]
[/TR]
[TR]
[TD]Project A[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Project B[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Project C[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Project D[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]Project E[/TD]
[TD]5[/TD]
[/TR]
</tbody>[/TABLE]

To help - the table I'm trying to colour looks like this. Each letter corresponds to a project and is calculated using a formula.

[TABLE="class: grid, width: 1002, align: center"]
<colgroup><col width="64" span="8" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Person ref[/TD]
[TD="width: 64"]08:00[/TD]
[TD="width: 64"]08:30[/TD]
[TD="width: 64"]09:00[/TD]
[TD="width: 64"]09:30[/TD]
[TD="width: 64"]10:00[/TD]
[TD="width: 64"]10:30[/TD]
[TD="width: 64"]11:00[/TD]
[/TR]
[TR]
[TD]12345[/TD]
[TD]A[/TD]
[TD]A[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]B[/TD]
[TD]B[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]22334[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]C[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]12533[/TD]
[TD]D[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]A[/TD]
[TD]A[/TD]
[TD]A[/TD]
[TD]A[/TD]
[/TR]
</tbody>[/TABLE]


Many thanks

 

[mumps]

Set up you reference table in Sheet2 with the project names in column A and the color index numbers in column B starting in row 2. You will have to decide which colors for each project. For example, the number 3 will give you red, 4 will give you green, 5 will give you blue. You can find the color index numbers by doing a quick online search. When you have all the color index numbers in place, run tis macro. Change the sheet names to suit your needs:

Sub colorCells()
    Application.ScreenUpdating = False
    Dim FoundProject As Range, project As Range, sAddr As String
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Set Sh1 = Sheets("Sheet1")
    Set Sh2 = Sheets("Sheet2")
    lCol = Sh1.Cells(1, Sh1.Columns.Count).End(xlToLeft).Column
    For Each project In Sh2.Range("A2:A" & Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row)
        Set FoundProject = Sh1.UsedRange.Offset(1, 1).Find(project, LookIn:=xlValues, lookat:=xlWhole)
        If Not FoundProject Is Nothing Then
            sAddr = FoundProject.Address
            Do
                FoundProject.Interior.ColorIndex = project.Offset(0, 1).Value
                Set FoundProject = Sh1.UsedRange.Offset(1, 1).FindNext(FoundProject)
            Loop While FoundProject.Address <> sAddr
            sAddr = ""
        End If
    Next project
    Application.ScreenUpdating = True
End Sub

 

[Pigmy]

Brilliant thanks. Works beautifully.

Is there a way for this to run permanently in the background rather than as a macro on request?

 

[mumps]

Would it help if the macro ran each time you open the file or each time you save or close the file? You said in your original post that

Each letter corresponds to a project and is calculated using a formula.

You could have it run automatically whenever any formula is calculated. With this approach, if you have a large dataset, it may take the macro a few seconds to run. This might be a little irritating because every time there is a calculation in one of the formulae, you would have that delay. Which method would work best for you?

 

[Pigmy]

I'd prefer it to run every time there is a calculation. I realise it would slow the spreadsheet down but the idea is that the spreadsheet is run once then provides a visual output that we can discuss so its not expected to be run multiple times during a discussion, just perhaps 3 or 4 times

Thanks again

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab for your Sheet1 and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet.

Private Sub Worksheet_Calculate()
    Application.ScreenUpdating = False
    Dim FoundProject As Range, project As Range, sAddr As String
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Set Sh1 = Sheets("Sheet1")
    Set Sh2 = Sheets("Sheet2")
    lCol = Sh1.Cells(1, Sh1.Columns.Count).End(xlToLeft).Column
    For Each project In Sh2.Range("A2:A" & Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row)
        Set FoundProject = Sh1.UsedRange.Offset(1, 1).Find(project, LookIn:=xlValues, lookat:=xlWhole)
        If Not FoundProject Is Nothing Then
            sAddr = FoundProject.Address
            Do
                FoundProject.Interior.ColorIndex = project.Offset(0, 1).Value
                Set FoundProject = Sh1.UsedRange.Offset(1, 1).FindNext(FoundProject)
            Loop While FoundProject.Address <> sAddr
            sAddr = ""
        End If
    Next project
    Application.ScreenUpdating = True
End Sub

Keep in mind that if no project name changes, nothing will happen. The macro will run automatically only when a project name changes as the result of the formula in the cell. I am assuming that there is a formula in each cell that contains a project name.

 

[Pigmy]

That's great thanks. Works really well. I forgot to mention that it needs to reset the cells to white between each calculation, otherwise it leaves the previous scenario as a "shadow" where there is no new data - I guess that's what you were highlighting in your comment about each cell containing a project. No - they don't always, sometimes they are blank (eg different start times). But I managed to figure out a way of resetting them all.

Many thanks for your help

 

[mumps]

You are very welcome. I'm not sure how you solved the problem but this macro will re-set the cells to white between each calculation.

Private Sub Worksheet_Calculate()
    Application.ScreenUpdating = False
    Dim FoundProject As Range, project As Range, sAddr As String
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Set Sh1 = Sheets("Sheet1")
    Set Sh2 = Sheets("Sheet2")
    Sh1.UsedRange.Offset(1, 1).Interior.ColorIndex = xlNone
    lCol = Sh1.Cells(1, Sh1.Columns.Count).End(xlToLeft).Column
    For Each project In Sh2.Range("A2:A" & Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row)
        Set FoundProject = Sh1.UsedRange.Offset(1, 1).Find(project, LookIn:=xlValues, lookat:=xlWhole)
        If Not FoundProject Is Nothing Then
            sAddr = FoundProject.Address
            Do
                FoundProject.Interior.ColorIndex = project.Offset(0, 1).Value
                Set FoundProject = Sh1.UsedRange.Offset(1, 1).FindNext(FoundProject)
            Loop While FoundProject.Address <> sAddr
            sAddr = ""
        End If
    Next project
    Application.ScreenUpdating = True
End Sub