Conditional Formatting Macro

Gronk_h8er

Board Regular
Joined
Jan 6, 2009
Messages
63
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.
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

lenze

Legend
Joined
Feb 18, 2002
Messages
13,690
You're close, except the WorkSheet_Change event may be the wrong tool. Are the cells in F2:AL200 already populated?

lenze
 

Gronk_h8er

Board Regular
Joined
Jan 6, 2009
Messages
63
Yes.

They are already populated.

Does this one only work if the cells change?
 
Joined
Jul 30, 2006
Messages
3,656
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

Board Regular
Joined
Jan 6, 2009
Messages
63

ADVERTISEMENT

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.
 
Joined
Jul 30, 2006
Messages
3,656
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
FGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
1*********************************12
2U*S*U*S*U*S***********************
3*U*S*U*S*U*S**********************
Letters



Excel Workbook
FGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
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
FGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
1*********************************12
2U*S*U*S*U*S***********************
3*U*S*U*S*U*S**********************
Letters



Excel Workbook
FGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
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
FGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
1*********************************26
2U*S*U*S*U*S***SSS****SUSU*********
3*U*S*U*S*U*S*****UUU******USUS****
Letters



Excel Workbook
FGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
1*********************************26
2-3*-2*-1*0*1*2*3****3210-1-2-3**********
3*-3*-2*-1*0*1*2*3**********0112-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).


Code:
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).

Code:
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).

Code:
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

Board Regular
Joined
Jan 6, 2009
Messages
63

ADVERTISEMENT

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?
 
Joined
Jul 30, 2006
Messages
3,656
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).


Code:
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

Banned
Joined
Sep 18, 2006
Messages
3,274
Amazing post alongwith awesome details and quite a handful of good knowledge, Mr. Stanley :biggrin:
Thanks to you, hope all is good !!
 

Watch MrExcel Video

Forum statistics

Threads
1,122,712
Messages
5,597,720
Members
414,168
Latest member
Manapo

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
Top