Conditional formatting a lot of different colours

Pigmy

New Member
Joined
Mar 3, 2010
Messages
24
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

RefColour
Project A1
Project B2
Project C3
Project D4
Project E5

<colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>
</tbody>

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

Person ref08:0008:3009:0009:3010:0010:3011:00
12345AAABBBB
22334BCCCDEE
12533DDEAAAA

<colgroup><col width="64" span="8" style="width:48pt"> </colgroup><tbody>
</tbody>


Many thanks
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
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:

Code:
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
 
Upvote 0
Brilliant thanks. Works beautifully.

Is there a way for this to run permanently in the background rather than as a macro on request?
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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.
Code:
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.
 
Last edited:
Upvote 0
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
 
Upvote 0
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.
Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,537
Messages
6,114,216
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top