Conditional formatting within a textbox

[Tonyd789]

Hi

I'm hoping someone on here will be kind enough to help me out with a little VBA coding to have a Text box display an coloured arrow depending on a cell value.

The reason for this is due to having a dashboard look to the sheet i'm working on which is made with a large shape that has a gradient finish to it unfortunately this covers all the cells behind.

How i want it to work is:-
If the referenced cell was greater the 0% then the arrow would be green and pointing upwards,
If the referenced cell was equal to 0% then the arrow would be yellow and point horizontally,
If the referenced cell was less than 0% then the arrow would be red and pointing down,

The textbox is called TextBoxArrow and is located on sheet 3.
The cell referenced is on sheet 6 and cell reference is J56.
I don't want the textbox itself to have any fill.

Many thanks in advance.

Tony

 

[Worf]

Hi

Here are two options, using text or pictures:

' Sheet6 module
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Shape
Set sh = Sheets("sheet3").Shapes("textbox1")    ' change name to suit
If Target = [j56] Then
    Select Case [j56]
        Case Is = 0
            sh.TextFrame2.TextRange.Characters.Text = ChrW(&H2192)
            sh.TextFrame.Characters.Font.ColorIndex = 44
        Case Is > 0
            sh.TextFrame2.TextRange.Characters.Text = ChrW(&H2191)
            sh.TextFrame.Characters.Font.ColorIndex = 4
        Case Is < 0
            sh.TextFrame2.TextRange.Characters.Text = ChrW(&H2193)
            sh.TextFrame.Characters.Font.ColorIndex = 3
    End Select
    sh.TextFrame.Characters.Font.Size = 18
End If
End Sub


' or...


Private Sub Worksheet_Change(ByVal Target As Range)
Dim s$
If Target = [j56] Then
    Select Case [j56]
        Case Is = 0
            s = "c:\pub\hor_arrow.jpg"
        Case Is > 0
            s = "c:\pub\up_arrow.jpg"
        Case Is < 0
            s = "c:\pub\down_arrow.jpg"
    End Select
    With Sheets("sheet3").Shapes("textbox1").Fill
        .Visible = 1
        .UserPicture s
        .TextureTile = 1
        .RotateWithObject = 1
    End With
End If
End Sub

 

[Tonyd789]

Thanks very much for the response i really appreciate it, I've gone with the first option but can't seem to get it working.

 

[Worf]

What happens exactly? Do you get an error? On what code line? Which Excel version are you using?

 

[Tonyd789]

Hi Worf thanks for replying, literally nothing happens, no error, project compiles with no issues.

this is the code i'm using and its located on sheet 6 where the reference cell is.

Private Sub Worksheet_Change(ByVal Target As Range)Dim sh As Shape
Set sh = Sheets("sheet3").Shapes("TextBox12")    ' change name to suit
If Target = [j56] Then
    Select Case [j56]
        Case Is = 0
            sh.TextFrame2.TextRange.Characters.Text = ChrW(&H2192)
            sh.TextFrame.Characters.Font.ColorIndex = 44
        Case Is > 0
            sh.TextFrame2.TextRange.Characters.Text = ChrW(&H2191)
            sh.TextFrame.Characters.Font.ColorIndex = 4
        Case Is < 0
            sh.TextFrame2.TextRange.Characters.Text = ChrW(&H2193)
            sh.TextFrame.Characters.Font.ColorIndex = 3
    End Select
    sh.TextFrame.Characters.Font.Size = 18
End If
End Sub

Why can't i step through the code using F8 or run it using F5, it opens the macro window?

 

[Worf]

• You cannot use F5 to run a routine that receives parameters.
• The code looks right; I am posting a link to my test workbook. Note that the box was inserted at Ribbon>Insert>Text Box.

https://www.dropbox.com/s/epmtibzpryze2q2/arrows.xlsm?dl=0