ID: 13
Category: Excel Automation
Question: Instead of using a pattern or a font for conditional formatting, can I show a green arrow?
Answer: Interesting idea. Here's one way to use a graphic image as a conditional indicator.
Option Explicit
Const cArrowName As String = "_TMArrow"
Sub addArrow(Sh As Object)
Dim anArrow As Shape
Set anArrow = Sh.Shapes.AddLine(204#, 151.5, 218.25, 151.5)
With anArrow
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipHorizontal
'.Left = ActiveCell.Left + ActiveCell.Width
'.Top = ActiveCell.Top + ActiveCell.Height / 2
.Width = 18#
.Line.ForeColor.RGB = RGB(0, 255, 0)
.Line.Visible = msoFalse
.Name = cArrowName
End With
End Sub
Sub useArrow(Sh As Object, Target As Range)
Dim anArrow As Shape, z As Shape
On Error Resume Next
Set anArrow = Sh.Shapes(cArrowName & Target.Address(True, True, xlR1C1))
On Error GoTo 0
If Not anArrow Is Nothing Then
Else
On Error Resume Next
Set anArrow = Sh.Shapes(cArrowName)
On Error GoTo 0
If anArrow Is Nothing Then
addArrow Sh
Set anArrow = Sh.Shapes(cArrowName)
End If
Set anArrow = anArrow.Duplicate
anArrow.Name = cArrowName & Target.Address(True, True, xlR1C1)
End If
With anArrow
.Visible = msoTrue
.Line.Visible = msoTrue
End With
With Target
anArrow.Left = .Left + .Width
anArrow.Top = .Top + .Height / 2
End With
End Sub
Sub deleteArrow(Sh As Object, Target As Range)
On Error Resume Next
Sh.Shapes(cArrowName & Target.Address(True, True, xlR1C1)).Delete
End Sub
Sub deleteMasterArrow()
On Error Resume Next
ActiveSheet.Shapes(cArrowName).Delete
End Sub
Put the foll. in the Workbook module
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim aCell As Range
On Error GoTo ErrXit
Application.EnableEvents = False
For Each aCell In Target.Cells
If IsNumeric(aCell.Value) And aCell.Value > 10 Then useArrow Sh, aCell _
Else deleteArrow Sh, aCell
Next aCell
ErrXit:
Application.EnableEvents = True
End Sub
ExtendedLink:
|