Change colour of cell depending on content

B

blain

I want to be able to change the background colour of a cell depending on
its content, I could use conditional formatting but I have more than
three conditions.

I have 14 different conditions.

Can someone provide me a generic VBA code to accomplish this.

The content is text rather than a number.

Hope someone can help.
 
N

Norman Jones

Hi Blain,
Will this work if the content of a cell is the result of a index forula?
Click to expand...

To allow for the formula, try the following version:

'=============>>
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim rng2 As Range

Set rng = Me.Range("A1") '<<==== CHANGE

On Error Resume Next
Set rng2 = Union(rng, rng.Precedents)
On Error GoTo 0

If Not Intersect(rng2, Target) Is Nothing Then
With rng
Select Case UCase(.Value)
Case "ANNE": .Interior.ColorIndex = 3
Case "BEN": .Interior.ColorIndex = 4
Case "CAROL": .Interior.ColorIndex = 5
Case "DAVID": .Interior.ColorIndex = 6
Case "EWAN": .Interior.ColorIndex = 7
Case "FREDA": .Interior.ColorIndex = 8
Case "GRAHAM": .Interior.ColorIndex = 9
Case "HARRY": .Interior.ColorIndex = 10
Case "IAN": .Interior.ColorIndex = 11
Case "JANE": .Interior.ColorIndex = 12
Case "KATE": .Interior.ColorIndex = 13
Case "LEN": .Interior.ColorIndex = 14
Case "MARY": .Interior.ColorIndex = 15
Case "NORA": .Interior.ColorIndex = 16
Case Else: .Interior.ColorIndex = xlNone
End Select
End With
End If

End Sub
'<<=============
 
B

blain

I must be doing something wrong

I cut and pasted your code, changed the range and the contents of the
cases to match those on my worksheet and nothing happens.

where am I going wrong?
 
N

Norman Jones

Hi Blain,

If you wish, you may send me your workbook:

norman_jones@NOSPAMbtconnectDOTcom

(Delete "NOSPAM" and replace "DOT" with a full stop [period] )

Alternatively, send me an email and I will respond with my test book.

BTW, to allow for the possibility that the formula is deleted or
overwritten, more robust would be:

'=============>>
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim rng2 As Range

Set rng = Me.Range("A1") '<<==== CHANGE

On Error Resume Next
Set rng2 = Union(rng, rng.Precedents)
On Error GoTo 0

If Not rng2 Is Nothing Then
If Not Intersect(rng2, Target) Is Nothing Then
With rng
Select Case UCase(.Value)
Case "ANNE": .Interior.ColorIndex = 3
Case "BEN": .Interior.ColorIndex = 4
Case "CAROL": .Interior.ColorIndex = 5
Case "DAVID": .Interior.ColorIndex = 6
Case "EWAN": .Interior.ColorIndex = 7
Case "FREDA": .Interior.ColorIndex = 8
Case "GRAHAM": .Interior.ColorIndex = 9
Case "HARRY": .Interior.ColorIndex = 10
Case "IAN": .Interior.ColorIndex = 11
Case "JANE": .Interior.ColorIndex = 12
Case "KATE": .Interior.ColorIndex = 13
Case "LEN": .Interior.ColorIndex = 14
Case "MARY": .Interior.ColorIndex = 15
Case "NORA": .Interior.ColorIndex = 16
Case Else: .Interior.ColorIndex = xlNone
End Select
End With
End If
End If
End Sub
'<<=============

The version change should, however, have no relevance to your problem.
 
T

tony h

I see Norman has moved things on a bit.

2 comments
1. make sure Normans code is in the "microsoft excel objects" ... "this
workbook " section not in the "modules" section.

2. I don't think you would want to change the colour pallette for this
sort of use so use the RGB function rather than colourindex

Cheers
 
T

Tom Ogilvy

re: "2."

Not sure I understand your advice.

Excel cells can only display 56 distinct colors at any one time and they are
all covered by ColorIndex. So using RGB and the color property add no
additional functionality.
 
N

Norman Jones

Hi Tony,
I see Norman has moved things on a bit.
Click to expand...
2 comments
1. make sure Normans code is in the "microsoft excel objects" ... "this
workbook " section not in the "modules" section.
Click to expand...

To avoid possible confusion, my suggested code represents worksheet event
code and, as such, should be placed in the appropriate worksheet module -
not in the workbook's ThisWorkbook module and not in a standard module. For
more explicit instructions, see my initial response to Steve (Blain).

However, in the absence of a post by Steve, and to provide a contextual
closure to the thread, the file which Steve sent me (a) relied on links to a
table in another sheet and (b) related to an extended range rather than the
single cell implied in his initial post. This being the case, I suggested
replacing my initial Worksheet_Change code with an appropriately amended
Worksheet_Calculate procedure, e.g.:

'=============>>
Private Sub Worksheet_Calculate()
Dim rng As Range
Dim rCell As Range

On Error Resume Next
Set rng = Me.Range("A1:AA23"). _
SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0

If Not rng Is Nothing Then
For Each rCell In rng.Cells
With rCell
Select Case UCase(.Value)
Case "G": .Interior.ColorIndex = 3
Case "G/S7": .Interior.ColorIndex = 4
Case "D14": .Interior.ColorIndex = 5
Case "D15": .Interior.ColorIndex = 6
Case "D16": .Interior.ColorIndex = 7
Case "COT MIX": .Interior.ColorIndex = 8
Case "DCOT14": .Interior.ColorIndex = 9
Case "D_CPS_14": .Interior.ColorIndex = 10
Case "DCOTBB14": .Interior.ColorIndex = 11
Case "COT/CPS": .Interior.ColorIndex = 12
Case "DCOTBB15": .Interior.ColorIndex = 13
Case "DCOTBB16": .Interior.ColorIndex = 14
Case "ISCBBsales": .Interior.ColorIndex = 15
Case "ISC/CRM": .Interior.ColorIndex = 16
Case Else: .Interior.ColorIndex = xlNone
End Select
End With
Next rCell
End If

End Sub
'<<=============

As far as your second comment:
2. I don't think you would want to change the colour pallette for this
sort of use so use the RGB function rather than colourindex
Click to expand...

is concerned, I would direct you to Tom Ogilvy's pithily pertinent response.
 
N

Norman Jones

Hi Blain,
I must be doing something wrong
Click to expand...

Not a great deal except that it was difficult, without seeing your workbook,
to appreciate the usage of formula links to another sheet.

Having seen your sheet and the range of interest, I would advocate replacing
the suggested code with a Worksheet_Calculate procedure like:

'=============>>
Private Sub Worksheet_Calculate()
Dim rng As Range
Dim rCell As Range

On Error Resume Next
Set rng = Me.Range("A1:AA23"). _
SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0

If Not rng Is Nothing Then
For Each rCell In rng.Cells
With rCell
Select Case UCase(.Value)
Case "G": .Interior.ColorIndex = 3
Case "G/S7": .Interior.ColorIndex = 4
Case "D14": .Interior.ColorIndex = 5
Case "D15": .Interior.ColorIndex = 6
Case "D16": .Interior.ColorIndex = 7
Case "COT MIX": .Interior.ColorIndex = 8
Case "DCOT14": .Interior.ColorIndex = 9
Case "D_CPS_14": .Interior.ColorIndex = 10
Case "DCOTBB14": .Interior.ColorIndex = 11
Case "COT/CPS": .Interior.ColorIndex = 12
Case "DCOTBB15": .Interior.ColorIndex = 13
Case "DCOTBB16": .Interior.ColorIndex = 14
Case "ISCBBsales": .Interior.ColorIndex = 15
Case "ISC/CRM": .Interior.ColorIndex = 16
Case Else: .Interior.ColorIndex = xlNone
End Select
End With
Next rCell
End If

End Sub
'<<=============

I have implemented this code in the updated version of your workbook which I
have sent you and, from my limited perspective, your stated objectives are
satisfied.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

conditional formatting 2
conditional formating in adjacent cells 2
How can i put text in a cell depending on colour 0
Can this be done with Excel 2007 VBA? 5
Conditional formatting with vba 3
Count Conditional Formatting Colours - Excel 2003 4
Excel does not accept text format! 0
Pasting a cell into bookmarked table from excel vba 1

Top