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: