Conditional Formatting Macro

[Gronk_h8er]

Hi,

I am trying to put together a heat map in excel 2003 and need to have more than 3 conditions. Therefore i need to use VBA.

For my range of cells F2:AL200, i need all cells that contain "U" to be red, all cells that contain "S" to be bright green and all cells that contain "" to be grey.

I have downloaded a macro from the web and tried to adjust it for my needs, but it doesn't seem to be working.

Please find it below...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer

If Not Intersect(Target, Range("F2:AL200")) Is Nothing Then
Select Case Target
Case Is = "U"
icolor = 3
Case Is = "S"
icolor = 4
Case Is = ""
icolor = 15
Case Else
'Whatever
End Select

Target.Interior.ColorIndex = icolor
End If

I am not proficient enough at VBA to figure out were i am going wrong so any help will be appreciated.

Also, while i am here...On a another sheet i want to create a similar heat map except now the conditions are numbers.

I need all numbers greater than 1 to be dark blue, all numbers that equal 1 to be light blue, all numbers that equal 0 to be green, all numbers that are equal to -1 to be orange and all numbers less than -1 to be red.

Thanks.

 

[lenze]

You're close, except the WorkSheet_Change event may be the wrong tool. Are the cells in F2:AL200 already populated?

lenze

 

[Gronk_h8er]

Yes.

They are already populated.

Does this one only work if the cells change?

 

[stanleydgromjr]

Gronk_h8er,

Does this one only work if the cells change?

Yes.


Are the cells in both tables already populated?

Are the cell values being manually changed, or are they changed via formula?

We can write a macro(s) to change all the colors per your request. Then, we can add the Worksheet_Change macro, for going forward.

For the first table - how many types of entres will there be, and what will the background color for those entries.


Have a great day,
Stan

 

[Gronk_h8er]

All the cells in both sheets are currently populated.

They are populated with formulas, so i don't changed them manually.

There is a sheet where all my data is input and then all susequent sheets change.

For the first table there are three kinds of entry "U", "S" and blank (ie "").

The background colour is 'no fill' but i want all the blank one to be grey. Would it be easier just to set the background to grey and then have anything that is a "U" or an "S" to change?

The second table has the ranges that i stated before,

I need all numbers greater than 1 to be dark blue, all numbers that equal 1 to be light blue, all numbers that equal 0 to be green, all numbers that are equal to -1 to be orange and all numbers less than -1 to be red.

Thanks heaps for your help on this.

Cheers.

 

[stanleydgromjr]

Gronk_h8er,

On the screenshots, empty cells will display "*".


You will have to adjust the sheet names to "Letters" and "Numbers" respectively.

If this is not acceptable, I can re-write the macros. What are the sheet names?


To start there are two macro "UpdateLetters", and "UpdateNumbers".

These two macros will have to be run to set the "Interior.ColorIndex" on your present data.

For the Letters sheet, copy the below formula into cell AM1:
=COUNTIF(F2:AL200,"S")+COUNTIF(F2:AL200,"U")

For the Numbers sheet, copy the below formula into cell AM1:
=COUNTIF(F2:AL200,0)+COUNTIF(F2:AL200,"<0")+COUNTIF(F2:AL200,">0")


Before the two macros:

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	12
2	U	*	S	*	U	*	S	*	U	*	S	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
3	*	U	*	S	*	U	*	S	*	U	*	S	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
Letters

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	14
2	-3	*	-2	*	-1	*	0	*	1	*	2	*	3	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
3	*	-3	*	-2	*	-1	*	0	*	1	*	2	*	3	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
Numbers

After running the two macros:

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	12
2	U	*	S	*	U	*	S	*	U	*	S	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
3	*	U	*	S	*	U	*	S	*	U	*	S	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
Letters

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	14
2	-3	*	-2	*	-1	*	0	*	1	*	2	*	3	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
3	*	-3	*	-2	*	-1	*	0	*	1	*	2	*	3	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*
Numbers

Then, as your formulas change automatically, the Worksheet_Calculate Event for each sheet will run the appropriate macro.

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	26
2	U	*	S	*	U	*	S	*	U	*	S	*	*	*	S	S	S	*	*	*	*	S	U	S	U	*	*	*	*	*	*	*	*	*
3	*	U	*	S	*	U	*	S	*	U	*	S	*	*	*	*	*	U	U	U	*	*	*	*	*	*	U	S	U	S	*	*	*	*
Letters

Excel Workbook
	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	*	26
2	-3	*	-2	*	-1	*	0	*	1	*	2	*	3	*	*	*	*	3	2	1	0	-1	-2	-3	*	*	*	*	*	*	*	*	*	*
3	*	-3	*	-2	*	-1	*	0	*	1	*	2	*	3	*	*	*	*	*	*	*	*	*	*	0	1	1	2	-3	*	*	*	*	*
Numbers

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Press and hold down the 'ALT' key, and press the 'F11' key.

On the 'Insert' menu, click 'Module'.

Copy the below code, and paste it into the Module (on the right pane).

Option Explicit
Sub UpdateLetters()
Dim c As Range
Application.ScreenUpdating = False
With Sheets("Letters")
  For Each c In .Range("F2:AL200").Cells
    Select Case UCase(c.Value)
      Case ""
        c.Interior.ColorIndex = 15
      Case "S"
        c.Interior.ColorIndex = 4
      Case "U"
        c.Interior.ColorIndex = 3
      Case Else
        c.Interior.ColorIndex = 15
    End Select
  Next c
End With
Application.ScreenUpdating = True
End Sub


Sub UpdateNumbers()
Dim c As Range
Application.ScreenUpdating = False
With Sheets("Numbers")
  For Each c In .Range("F2:AL200").Cells
    Select Case c.Value
      Case ""
        c.Interior.ColorIndex = xlNone
      Case Is < -1
        c.Interior.ColorIndex = 3    'Red
      Case Is = -1
        c.Interior.ColorIndex = 44   'Orange
      Case Is = 0
        c.Interior.ColorIndex = 4    'Green
      Case Is = 1
        c.Interior.ColorIndex = 33   'Light Blue
      Case Is > 1
        c.Interior.ColorIndex = 5    'Dark Blue
    End Select
  Next c
End With
Application.ScreenUpdating = True
End Sub

Right click the sheet tab "Letters" you want the code in, and click on View Code. Paste the below code there (on the right pane).

Option Explicit
Dim OldValLetters As Variant
Private Sub Worksheet_Calculate()
If Range("AM1").Value <> OldValLetters Then
  OldValLetters = Range("AM1").Value
  Call UpdateLetters
End If
Application.EnableEvents = True
End Sub

Right click the sheet tab "Numbers" you want the code in, and click on View Code. Paste the below code there (on the right pane).

Option Explicit
Dim OldValNumbers As Variant
Private Sub Worksheet_Calculate()
If Range("AM1").Value <> OldValNumbers Then
  OldValNumbers = Range("AM1").Value
  Call UpdateNumbers
End If
Application.EnableEvents = True
End Sub

Make sure that "Tools", "Options", "Calculation" tab is set for/ticked "Automatic".

Then, as your cell formulas change, the respective "Worksheet_Calculate" Event will run the respective macro to change the "Interior.ColorIndex" of each cell.


Have a great day,
Stan

 

[Gronk_h8er]

This worked perfectly save for my colour index number 3 not being red!

Instead it returns a pale yellow...

Is there some way to reassign the colour index to red?

 

[stanleydgromjr]

Gronk_h8er,

In a new workbook, run the following code, to determine the color index on you computer.

Then change the "3" in the "UpdateLetters", and "UpdateNumbers" macros, to the correct number on your computer.


Press and hold down the 'ALT' key, and press the 'F11' key.

On the 'Insert' menu, click 'Module'.

Copy the below code, and paste it into the Module (on the right pane).

Option Explicit
Sub RunColorIndex()
'
' jim may
' http://www.mrexcel.com/forum/showthread.php?t=321553
' Modified by stanleydgromjr
'
Dim i As Integerr
With Range("A1:B1")
  .Value = Array("Interior.ColorIndex", "Color")
  .HorizontalAlignment = xlCenter
End With
Range("A2").Select
For i = 1 To 48
  With ActiveCell
    .Value = i
    .HorizontalAlignment = xlCenter
  End With
  With ActiveCell.Offset(, 1)
    .Interior.ColorIndex = i
    .Value = i
    .HorizontalAlignment = xlCenter
  End With
  ActiveCell.Offset(1).Select
Next i
Range("A1:B1").ColumnWidth = 16
End Sub

Then run the "" macro.


Have a great day,
Stan

 

[Stormseed]

Amazing post alongwith awesome details and quite a handful of good knowledge, Mr. Stanley
Thanks to you, hope all is good !!

 

[stanleydgromjr]

Stormseed,

Thank you very much, from a fellow coder.


Have a great day,
Stan