Different Autoshape per Results 2

[shelby55]

Hello

I am using Excel 2003 and would like to add an autoshape to my worksheet for users to synopsize the worksheet results.

The shapes will be red octagon, yellow triangle and green circle and all will have text in them.

Thanks to Skip and PHV I have the following code for use with a graph in a different workbook...how do I edit for use with multiple autoshape types (this one has only faces with different traits)?

Sub Chart_Activate()
Dim oSmiley As Shape

    Dim BaseLine, Tgt, Actual
    Dim lngRowNum As Long
        
    With Sheets("Graph_Data")
    'this is because if not a full week for most current date
    'then data and date will be in B28 not B29
    
        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
'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, 590.18, 7.06, 77.63, 79.42)
        With oSmiley
            Select Case Actual
                Case Is < BaseLine  'RED frown
                    .Adjustments.Item(1) = 0.7180555
                    .Fill.ForeColor.RGB = RGB(255, 0, 0)
                
                Case Is >= Tgt      'GREEN smile
                    .Adjustments.Item(1) = 0.8111111
                    .Fill.ForeColor.RGB = RGB(0, 255, 0)
                    
                Case Else          'YELLOW neutral
                    .Adjustments.Item(1) = 0.7703704
                    .Fill.ForeColor.RGB = RGB(255, 204, 0) 
            End Select
        End With
    End With
End Sub

Note that I can change the criteria and reference cells...I just need to know how to reference the different shapes.

Thanks!

 

[shelby55]

Hi Skip

I haven't named it logo but I did use the name I have in place of PHV's "logo" in his code so it doesn't work.

I named the logo the same way I named the pictures.

Below is the code:

Sub showshape(sName As String)
Dim sp As Shape

Application.ScreenUpdating = False
For Each sp In ActiveSheet.Shapes
With sp
    Select Case .Name
        Case sName, "shelby"
            sp.Visible = True
        Case Else
            sp.Visible = False
    End Select
    End With
    Next
    Application.ScreenUpdating = True
End Sub

Sub Chart_Activate()
    Dim BaseLine, Tgt, Actual
    Dim lngRowNum As Long
    Dim sp As Shape
        
    With Sheets("Graph_Data")  
        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

        Application.ScreenUpdating = False
        For Each sp In ActiveSheet.Shapes
        With sp
       
            Select Case Actual
                Case Is < BaseLine  'RED shark
                    showshape "spShark"
                                      
                Case Is >= Tgt      'GREEN star
                    showshape "spStar"
                    
                Case Else          'YELLOW dolphin
                    showshape "spDolphin"
            End Select
        End With
        Next
        Application.ScreenUpdating = True
End Sub

So what am I doing wrong? Thanks.

 

[PHV]

I named the logo the same way I named the pictures
So, shelby or spShelby ?

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

 

[shelby55]

Hi

I didn't name it right but once I changed the name and included that in the code it worked!

Thank you to all who helped out on this, I really appreciate it.

 

[shelby55]

Hello Again

I have one more question on this: if I want to create more graphs but use the same images, will I need to copy all 3 images per graph (which could make the copy file quite large)? Or is there a way to call the ones from either this initial graph or save to another sheet and "copy" from there?

Thanks.