AutoColour Arrows

Hi,

I have some code that autocolours my Ovals, can anyone amend my code so that it autocolours my arrows.

Private Sub Worksheet_Calculate()
    Dim ovl                   As Oval

    For Each ovl In Me.Ovals
        If Range(Trim$(ovl.Formula)).Value < 0 Then
            ovl.Interior.Color = vbRed
            ovl.Font.Color = vbWhite
        Else
            ovl.Interior.Color = vbGreen
            ovl.Font.Color = vbBlack
        End If
    Next ovl

End Sub

Open in new window

Seamus2626Asked:
Who is Participating?
 
Rgonzo1971Commented:
Hi,

pls try

Sub switcharrowsbasedonformulame()
'
' SwitchArrow Macro
'

'
Dim shpArrow As Shape
For Each shpArrow In Worksheets("Pivot Tables HORIS").Shapes
    If shpArrow.Type = msoAutoShape And (shpArrow.AutoShapeType = msoShapeUpArrow) Then

        If Len(shpArrow.OLEFormat.Object.Formula) > 0 Then
            If Val(Split(Range(shpArrow.OLEFormat.Object.Formula), " ")(1)) < 0 Then
                'rotate if negative
'                shpArrow.Flip msoFlipVertical
                'for up arrow 180 is pointing up, 0 is pointing down -- it is different for other shapes
                shpArrow.Rotation = 0
                shpArrow.Fill.ForeColor.RGB = vbRed
                shpArrow.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbWhite
                Else
                shpArrow.Rotation = 180
                shpArrow.Fill.ForeColor.RGB = vbGreen
                shpArrow.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbBlack
            End If
        End If
'shpArrow.characters.text is the text
        
    End If
Next
End Sub

Open in new window

0
 
Rgonzo1971Commented:
Which arrows?
0
 
Seamus2626Author Commented:
So, I have arrows as opposed to Ovals on my spreadsheet, so where the code is changing the shape Oval, it needs to change the arrows on a sheet
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Rgonzo1971Commented:
Could you send a dummy
0
 
Seamus2626Author Commented:
Attached, thanks!
ss.xlsm
0
 
Seamus2626Author Commented:
Perfect, thanks Rgonzo!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.