Formatting variances using .jpeg

[gagolmo]

Hi There, could someone help me writing the IF statement that will apply green arrow up image when variance is greater than 0 and red arrow down image to negative variance?
Thanks!

[Bernie Deitrick]

You could use CF. For example, select the cells, choose CF / Icon Sets / More Rules... and then set the icon for > 0 to green arrow, and <0 to a red arrow.

[gagolmo]

Hi Bernie,
The problem is that I want to use the images cause they are much sleeker. Do you know how to do that?
Thank you for the replay!

[Bernie Deitrick]

Insert your two pictures onto the worksheet, and name them UpArrow and DownArrow

Then copy this code, right-click the sheet tab, select "View Code" and paste the code into the window that appears. Then save the workbook as a macro-enabled .xlsm file. Change the "B:B" to the range of cells with the variance formulas.

Private Sub Worksheet_Calculate()

Dim myShape As Shape
Dim r As Range
Dim mySh As Worksheet

Application.EnableEvents = False
Application.ScreenUpdating = False
Set mysht = ActiveSheet

On Error Resume Next
For Each myShape In mysht.Shapes
   If myShape.Name Like "*Final" Then myShape.Delete
Next myShape

For Each r In Range("B:B").SpecialCells(xlCellTypeFormulas)
If r.Value > 0 Then
    ActiveSheet.Shapes("UpArrow").Select
    Selection.Copy
    r.Select
    ActiveSheet.Paste
Else
    ActiveSheet.Shapes("DownArrow").Select
    Selection.Copy
    r.Select
    ActiveSheet.Paste
End If

Selection.Name = r.Address & "Final"
Selection.Top = r.Top
Selection.Left = r.Left
Next r
Application.EnableEvents = True
Application.ScreenUpdating = True


End Sub

[gagolmo]

Bernie, it works for UpArrow but not for DownArrow, but probably I am not running this code correctly. And just one more question, how to place the arrows in C column next to variances in B? thanks

[Bernie Deitrick]

It should work for both - can you post your file?

To place the pictures in the next column, use r(1,2) instead of r, like

Private Sub Worksheet_Calculate()

Dim myShape As Shape
Dim r As Range
Dim mySh As Worksheet

Application.EnableEvents = False
Application.ScreenUpdating = False
Set mysht = ActiveSheet

On Error Resume Next
For Each myShape In mysht.Shapes
   If myShape.Name Like "*Final" Then myShape.Delete
Next myShape

For Each r In Range("B:B").SpecialCells(xlCellTypeFormulas)
If r.Value > 0 Then
    ActiveSheet.Shapes("UpArrow").Select
    Selection.Copy
    r(1, 2).Select
    ActiveSheet.Paste
Else
    ActiveSheet.Shapes("DownArrow").Select
    Selection.Copy
    r(1, 2).Select
    ActiveSheet.Paste
End If

Selection.Name = r(1, 2).Address & "Final"
Selection.Top = r(1, 2).Top
Selection.Left = r(1, 2).Left
Next r
Application.EnableEvents = True
Application.ScreenUpdating = True


End Sub

[FDibbins]

Conditional Formatting is designed for this, and will be much simpler

[gagolmo]

ok, thank you.