Shape coloring macro tied to formula

**dreddster** · 07-17-2013, 07:37 AM

Hey guys,

This is probably something easy but I can't figure it out. I have this macro to color shapes depending on the value

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rng1 As Range, rng2 As Range, rng3 As Range

Set rng1 = [T5]
Set rng2 = [U5]
Set rng3 = [V5]

If Intersect(Target, Union(rng1, rng2, rng3)) Is Nothing Then Exit Sub

Dim shp1 As Shape, shp2 As Shape, shp3 As Shape
Dim bytColor1 As Byte, bytColor2 As Byte, bytColor3 As Byte
Set shp1 = ActiveSheet.Shapes("Oval 38")
Set shp2 = ActiveSheet.Shapes("Oval 47")
Set shp3 = ActiveSheet.Shapes("Oval 65")

Select Case rng1
    Case 57 To 100
        bytColor1 = 2
    Case 26 To 56
        bytColor1 = 5
    Case 1 To 25
        bytColor1 = 3
    Case Else
        bytColor1 = 1
End Select
Select Case rng2
    Case 68 To 100
        bytColor2 = 2
    Case 34 To 67
        bytColor2 = 5
    Case 0 To 33
        bytColor2 = 3
    Case Else
        bytColor2 = 1
End Select
Select Case rng3
    Case 0 To 25
        bytColor3 = 2
    Case 26 To 56
        bytColor3 = 5
    Case 57 To 100
        bytColor3 = 3
    Case Else
        bytColor3 = 1
End Select
shp1.Fill.ForeColor.SchemeColor = bytColor1
shp2.Fill.ForeColor.SchemeColor = bytColor2
shp3.Fill.ForeColor.SchemeColor = bytColor3
End Sub

Works fine when I enter values from 1 to 100 at T5, U5, V5. However these cells should be formulas and when I change them, coloring stops working.(for example this is the formula for T5: =IFERROR((($T$2/$T$3)*6.25)/100; "")

How do I fix this?

Thank you!

**JosephP** · 07-17-2013, 07:50 AM

formula calculations do not trigger the change event so you would have to use the calculate event and check all the cells each time it triggers (there is no Target argument for the Calculate event)

**dreddster** · 07-17-2013, 08:24 AM

I think you overestimated my knowledge on VBA

What I understand from your response is that this macro wont work with formulas, and I should look for a macro that starts with Worksheet_calculate to do the job, right? Oh, well I will look for one now.

Thank you Josie.

**JosephP** · 07-17-2013, 08:27 AM

Private Sub Worksheet_Calculate()

Dim rng1 As Range, rng2 As Range, rng3 As Range

Set rng1 = [T5]
Set rng2 = [U5]
Set rng3 = [V5]

Dim shp1 As Shape, shp2 As Shape, shp3 As Shape
Dim bytColor1 As Byte, bytColor2 As Byte, bytColor3 As Byte
Set shp1 = ActiveSheet.Shapes("Oval 38")
Set shp2 = ActiveSheet.Shapes("Oval 47")
Set shp3 = ActiveSheet.Shapes("Oval 65")

Select Case rng1
    Case 57 To 100
        bytColor1 = 2
    Case 26 To 56
        bytColor1 = 5
    Case 1 To 25
        bytColor1 = 3
    Case Else
        bytColor1 = 1
End Select
Select Case rng2
    Case 68 To 100
        bytColor2 = 2
    Case 34 To 67
        bytColor2 = 5
    Case 0 To 33
        bytColor2 = 3
    Case Else
        bytColor2 = 1
End Select
Select Case rng3
    Case 0 To 25
        bytColor3 = 2
    Case 26 To 56
        bytColor3 = 5
    Case 57 To 100
        bytColor3 = 3
    Case Else
        bytColor3 = 1
End Select
shp1.Fill.ForeColor.SchemeColor = bytColor1
shp2.Fill.ForeColor.SchemeColor = bytColor2
shp3.Fill.ForeColor.SchemeColor = bytColor3
End Sub

for instance :-)

**dreddster** · 07-17-2013, 08:46 AM

This is awesome, works like a charm!

Thank you so much Josie!

**JosephP** · 07-17-2013, 08:48 AM

you're welcome :-)

**dreddster** · 07-17-2013, 11:03 AM

Hmm, one more question.
When I open another excel file I get an error, as it seems the new file runs the macro from this workbook.

How do I limit this macro only to this file? (Also I change the names all the time like V22, V23 etc., if that can be taken into account).

**JosephP** · 07-17-2013, 11:19 AM

perhaps

Private Sub Worksheet_Calculate()

Dim rng1 As Range, rng2 As Range, rng3 As Range

Set rng1 = Range("T5")
Set rng2 = Range("U5")
Set rng3 = Range("V5")

Dim shp1 As Shape, shp2 As Shape, shp3 As Shape
Dim bytColor1 As Byte, bytColor2 As Byte, bytColor3 As Byte
Set shp1 = Me.Shapes("Oval 38")
Set shp2 = Me.Shapes("Oval 47")
Set shp3 = Me.Shapes("Oval 65")

Select Case rng1
    Case 57 To 100
        bytColor1 = 2
    Case 26 To 56
        bytColor1 = 5
    Case 1 To 25
        bytColor1 = 3
    Case Else
        bytColor1 = 1
End Select
Select Case rng2
    Case 68 To 100
        bytColor2 = 2
    Case 34 To 67
        bytColor2 = 5
    Case 0 To 33
        bytColor2 = 3
    Case Else
        bytColor2 = 1
End Select
Select Case rng3
    Case 0 To 25
        bytColor3 = 2
    Case 26 To 56
        bytColor3 = 5
    Case 57 To 100
        bytColor3 = 3
    Case Else
        bytColor3 = 1
End Select
shp1.Fill.ForeColor.SchemeColor = bytColor1
shp2.Fill.ForeColor.SchemeColor = bytColor2
shp3.Fill.ForeColor.SchemeColor = bytColor3
End Sub

not sure what you meant about changing the names-what names?

**dreddster** · 07-17-2013, 11:29 AM

Now it is perfect!

Thank you once again for your help

Shape coloring macro tied to formula

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Re: Shape coloring macro tied to formula

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Use a button to control a macro that inserts an image into a shape or resets the shape

Spoof Application.Caller? Need to execute a shape's assigned macro as that shape through V

Need help programming a Macro tied to a button

macro/vba code for multiple cell coloring, adding boarder, and copying down formula.....

Sorting and coloring cells, formula or macro help needed

Bookmarks

Bookmarks

Posting Permissions