|
Private Sub Worksheet_Calculate()
Select Case Range("C3").Value
Case Is < Range("C4").Value
SetArrow 10, msoShapeDownArrow
Case Is > Range("C4").Value
SetArrow 3, msoShapeUpArrow
End Select
End Sub
Private Sub SetArrow()
' The following code is added to remove the prior shapes
For Each sh In ActiveSheet.Shapes
If sh.Name Like "*Arrow*" Then
sh.Delete
End If
Next sh
ActiveSheet.Shapes.AddShape(20, 17.25, 43.5, 5, 10).Select
With Selection.ShapeRange
With .Fill
.Visible = msoTrue
.Solid
.ForeColor.SchemeColor = 2
.Transparency = 0#
End With
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
End With
End Sub
|