VBA To Format Autoshape Based on Conditions 1

[shelby55]

Hello

I am using Excel 2003.

I have a dashboard type report that has graphs. I want to be able to program a face (happy, frown, indifferent) based on the results of another cell.

How can I do this via VBA? I was thinking that I'll need all 3 faces on the page but the applicable one is only visible (with the right colour) based on the results of the specific cell compared to its target.

How do I go about doing this - thanks.

Shelby

 

[SkipVought]

I can't say why it did not work for you and worked for me. Either the COLUMN LETTER or the Column NUMBER should work. The NUMBER is more often used, however.

Bottom line, we found a solution.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

Hi Skip

You absolutely rock...thank you so much for sticking with me on this. I think we hit a record for number of posts in one thread!! It's really too bad I can only give you one star because this is an above and beyond kind of effort on your part.

Thanks again!!

 

[SkipVought]

Pleased to be part of a positive process.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

Hi Skip

I didn't know if I should open up a new thread on this but the "smilyface" module/function isn't copying to the new worksheet so it's not working there.

What do I need to do in the "save as copy" so that it will save? Note that when I open the copy I am advised that there is a compile error: sub or function not defined and it specified the smilyface sub.

Thanks.

 

[SkipVought]

Yes, Please start a new thread if necessary.

But the bottom line is that you previously stated, "The workbook queries the database on open and then saves a copy elsewhere," when it does NOT save a copy of the workbook. It saves a copy of SHEETS within the workbook.

So do a SaveAs of the workbook to this other name, then delete the sheets you do not desire to have in the work book and save again before closing it.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[SkipVought]

...or how about moving the SmilyFace code to the Chart Sheet Code Window? Then you can leave the current copy mothod in tact.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

Hi Skip

Awesome....just moved it to the chart sheet code and it copies over to the copy!

Thanks again, Skip!

 

[SkipVought]

No extra charge! ;-)

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

Hi Skip

I'm just going to make one more note for anyone who has the strength to wade through our novel: the adjustments code that you used for the faces didn't work for me - they were all frowns though the colours changed. I had to go back to my original values that I found through running a macro:

With oSmiley
            Select Case Actual
                Case Is < BaseLine  'RED frown
                    .Adjustments.Item(1) = 0.7181
                    .Fill.ForeColor.RGB = RGB(255, 0, 0)
                Case Is >= Tgt      'GREEN smile
                    
                    .Fill.ForeColor.RGB = RGB(0, 255, 0)
                Case Else          'YELLOW neutral
                    .Adjustments.Item(1) = 0.7727
                    .Fill.ForeColor.RGB = RGB(255, 204, 0)
            End Select
        End With

and this works. Have a great day Skip!!

 

[SkipVought]

Here's how to absolutely check these values.

Add a SmileyFace shape to a sheet

Use this code to determine the SMILE face adjustment...

Sub Test()
Debug.Print ActiveSheet.Shapes(1).Adjustments.Item(1)
End Sub

Drag the Adjustment Handle (see VBA Help on the Adjustments Object) to a NEUTRAL position.

Run the code.

Drag the Adjustment Handle to a FROWN position.

Run the code.

View the three results, SMILE, NEUTRAL, FROWN in the Immediate Window.

In part VBA Help states...

In most cases, if you specify a value that’s beyond the range of valid values, the closest valid value will be assigned to the adjustment.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

Hi Skip

Good advice for all future checks..you'll make a programmer out of me yet!!

 

[SkipVought]

I am interested in knowing what values you get, running thru this process.



Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

Hi

Okay I get:
.7703704 for neutral
.8111111 for smile
.7180555 for frown

 

[SkipVought]

Hmmmmm. Velly intellesting???

Thanks for indulging my curiosity.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[shelby55]

No problem...it's the least I could do after all your help!!

 

[shelby55]

Hi Skip

Sorry to bug you again but I'm not sure how to edit this code for a condition that has come up.

If the last date in the raw data worksheet is not a full week then the graph_data worksheet isn't going to have a date in B29 but will in B28 so I can't absolute reference X29, Y29 and Z29. How do I add If statements to the first portion to indicate if cell B29 is empty then actual = X28 else use X29.

The current code is:

Option Explicit

Sub SmilyFace()
    Dim oSmiley As Shape
    Dim BaseLine, Tgt, Actual
    With Sheets("Dashboard Wk Calcs")
       Actual = .Cells(29, 24).Value
       BaseLine = .Cells(29, 25).Value
       Tgt = .Cells(29, 26).Value
    End With
'this must refer to the proper chart object in your VBA Project
    With Chart8
        For Each oSmiley In .Shapes
        If oSmiley.AutoShapeType = msoShapeSmileyFace Then _
                oSmiley.Delete
        Next
        Set oSmiley = .Shapes.AddShape(msoShapeSmileyFace, .PlotArea.InsideWidth, 0, 100, 100)
'if actual>=target then green happy face,
'if actual <target but >=baseline then yellow neutral face, '
'if actual <baseline then red frown face.
        With oSmiley
            Select Case Actual
                Case Is >= Tgt
                    
                    .Fill.ForeColor.RGB = RGB(0, 255, 0)
                    
                Case Is < BaseLine
                    .Adjustments.Item(1) = 0.7181
                    .Fill.ForeColor.RGB = RGB(255, 0, 0)
                
                Case Is < Tgt
                    .Adjustments.Item(1) = 0.7727
                    .Fill.ForeColor.RGB = RGB(255, 204, 0)
            End Select
        End With
    End With
End Sub

Thanks Skip (or anyone else who wants to jump in here!).

 

[PHV]

...
Dim BaseLine, Tgt, Actual, lngRowNum As Long
With Sheets("Dashboard Wk Calcs")
  If IsDate(.Cells(29, 2).Value) Then
    lngRowNum = 29
  Else
    lngRowNum = 28
  End If
  Actual = .Cells(lngRowNum, 24).Value
  BaseLine = .Cells(lngRowNum, 25).Value
  Tgt = .Cells(lngRowNum, 26).Value
End With
...

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[shelby55]

Hi PHV

Thank you so much - worked great!