Solved

Excel VB Shapes: Change for and text based upon certain variables

Posted on 2007-11-26
9
459 Views
Last Modified: 2013-12-02
I have a bunch of different shapes on a page. These shpaes will change a certain color based up a specifc circumstance in a specifc cell. I need my code to work like this: If cell f8 greater than or equal to f9 then change the shape interior color to green if f8 is less than or equal to 10% of f9 than change it yelow and if f8 is more than 10% less than f9 than change it to red or if cell f9 is blank than change the interior color to white with black font. Every oval must also have the value of cell f8 put inside of it as text. I have some code below, but i couldn't figure out how to make this work. Thanks for the help.

Sub Shape()
Sheets("Performance-Reliability").Select
ActiveSheet.Shapes("One").Fill.ForeColor.RGB = RGB(255, 0, 0)
Shapes("One").TextFrame.TextRange.Text = a1

End Sub

0
Comment
Question by:tchristie33
  • 5
  • 4
9 Comments
 
LVL 80

Accepted Solution

by:
byundt earned 500 total points
ID: 20355285
tchristie33,
If you want to format all shapes whose name begins with "Oval", then consider a macro like this:

Sub FormatShapes()
Dim shp As Shape
Application.ScreenUpdating = False
For Each shp In ActiveSheet.Shapes
    If LCase(shp.Name) Like "oval*" Then
        If [F9] = "" Then
            shp.Fill.ForeColor.SchemeColor = 2  'White
        Else
            Select Case [F8/F9]
            Case Is >= 1
                shp.Fill.ForeColor.SchemeColor = 4  'Green
            Case Is <= 0.1
                shp.Fill.ForeColor.SchemeColor = 6  'Yellow
            Case Else
                shp.Fill.ForeColor.SchemeColor = 3  'Red
            End Select
        End If
        shp.TextFrame.Characters.Text = [F8]
    End If
Next
Application.ScreenUpdating = True
End Sub


Brad
0
 

Author Comment

by:tchristie33
ID: 20355798
I think i could use something liek that but, i will be using 8 different shapes.... what would you suggest for that? Thanks
0
 
LVL 80

Expert Comment

by:byundt
ID: 20357636
The suggested code assumes that your shapes are named "Oval 1", "Oval 2", "Oval 3", etc. This is the default naming convention if you created them using the Oval drawing tool.

If that won't work, are there any other shapes on the worksheet?

What exactly are the names of the eight shapes?


Brad

0
 

Author Comment

by:tchristie33
ID: 20357921
I can name them what ever is easiest, but the issue is that each of the eight shapes is referencing different cells, so the first shape is using f8 and f9 but the next shape is using f23 and f24
0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 80

Expert Comment

by:byundt
ID: 20358067
Not quite the same as your original question, eh?


Try the following tweak to the original macro. It assumes the shape object is located on the same row as F8, F23, etc. The shapes in question must still be named something beginning with "Oval".

The revised code uses the TopLeftCell property of the shape object to tell where it is located. To find the top left cell, the easy way is to select the object. The Top left open circle of the selection marquee is over the top left cell. You'll need to define a relationship between the row of the top left cell and the two cells you need to reference for the color. The revised code assumed they were on the same row (and the next one).

I changed the SchemeColor values. Silly me. I thought they would be the same as the ColorIndex. The revised values give white, green, yellow and red in my Excel 2003.

Brad
Sub FormatShapes()

Dim shp As Shape

Dim cel1 As Range, cel2 As Range, targ As Range

Application.ScreenUpdating = False

With Worksheets("Performance-Reliability")

    For Each shp In .Shapes

        If LCase(shp.Name) Like "oval*" Then

            Set targ = shp.TopLeftCell      'The cell lying under top left corner of the shape object

            Set cel1 = .Cells(targ.Row, 6)  'Column F, same row

            Set cel2 = cel1.Offset(1, 0)    'Column F, next row

            If cel2 = "" Then

                shp.Fill.ForeColor.SchemeColor = 9  'White

            Else

                Select Case cel1 / cel2

                Case Is >= 1

                    shp.Fill.ForeColor.SchemeColor = 3  'Green

                Case Is <= 0.1

                    shp.Fill.ForeColor.SchemeColor = 13  'Yellow

                Case Else

                    shp.Fill.ForeColor.SchemeColor = 10  'Red

                End Select

            End If

            shp.TextFrame.Characters.Text = cel1

        End If

    Next

End With

Application.ScreenUpdating = True

End Sub

Open in new window

0
 

Author Comment

by:tchristie33
ID: 20360638
IWhat i have below is working perfectly.....can that be simplified? also how do i make this line of code make the text black and not white?
ActiveSheet.Shapes("One").TextFrame.Characters.Text = "PLT" & [f8]
Sub FormatShapes()

Application.ScreenUpdating = False

'My Space PLT

        If [G8] = "" Then

            ActiveSheet.Shapes("One").Fill.ForeColor.RGB = RGB(255, 255, 255) 'White

        Else

        If [F8/G8] <= 1 Then

                ActiveSheet.Shapes("One").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        If [f8] > [G8] Then

        If [F8 -(G8*.1)] <= [G8] Then

                ActiveSheet.Shapes("One").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        End If

        If [F8 -(G8*.1)] > [G8] Then

                ActiveSheet.Shapes("One").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

            ActiveSheet.Shapes("One").TextFrame.Characters.Text = "PLT" & [f8]

        End If

        'Competitor

        If [f7] >= [f8] Then

            ActiveSheet.Shapes("Two").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        

        If [F7 -(F8*.2)] <= [f8] Then

            ActiveSheet.Shapes("Two").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        If [F7 -(F8*.2)] > [f8] Then

            ActiveSheet.Shapes("Two").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

        ActiveSheet.Shapes("Two").TextFrame.Characters.Text = "PLT" & [f7]

        

'Yeh PLT

If [G24] = "" Then

            ActiveSheet.Shapes("Three").Fill.ForeColor.RGB = RGB(255, 255, 255) 'White

        Else

        If [F24/G24] <= 1 Then

                ActiveSheet.Shapes("Three").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        If [f24] > [G24] Then

        If [F24 -(G24*.1)] <= [G24] Then

                ActiveSheet.Shapes("Three").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        End If

        If [F24 -(G24*.1)] > [G24] Then

                ActiveSheet.Shapes("Three").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

            ActiveSheet.Shapes("Three").TextFrame.Characters.Text = "PLT" & [f24]

        End If

        'Competitior

        If [f23] >= [f24] Then

            ActiveSheet.Shapes("Four").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        

        If [F23 -(F24*.2)] <= [f24] Then

            ActiveSheet.Shapes("Four").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        If [F23 -(F24*.2)] > [f24] Then

            ActiveSheet.Shapes("Four").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

        ActiveSheet.Shapes("Four").TextFrame.Characters.Text = "PLT" & [f23]

        

' Mail PLT

If [G40] = "" Then

            ActiveSheet.Shapes("Five").Fill.ForeColor.RGB = RGB(255, 255, 255) 'White

        Else

        If [F40/G40] <= 1 Then

                ActiveSheet.Shapes("Five").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        If [F40] > [G40] Then

        If [F40 -(G40*.1)] <= [G40] Then

                ActiveSheet.Shapes("Five").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        End If

        If [F40 -(G40*.1)] > [G40] Then

                ActiveSheet.Shapes("Five").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

       

            ActiveSheet.Shapes("Five").TextFrame.Characters.Text = "PLT" & [F40]

        End If

        'Competitor

        If [f39] >= [F40] Then

            ActiveSheet.Shapes("Six").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        

        If [F39 -(F40*.2)] <= [F40] Then

            ActiveSheet.Shapes("Six").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        If [F39 -(F40*.2)] > [F40] Then

            ActiveSheet.Shapes("Six").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

        ActiveSheet.Shapes("Six").TextFrame.Characters.Text = "PLT" & [f39]

        

'4 PLT

If [G56] = "" Then

            ActiveSheet.Shapes("Seven").Fill.ForeColor.RGB = RGB(255, 255, 255) 'White

        Else

        If [F56/G56] <= 1 Then

                ActiveSheet.Shapes("Seven").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        If [F56] > [G56] Then

        If [F56 -(G56*.1)] <= [G56] Then

                ActiveSheet.Shapes("Seven").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        End If

        If [F56 -(G56*.1)] > [G56] Then

                ActiveSheet.Shapes("Seven").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

            ActiveSheet.Shapes("Seven").TextFrame.Characters.Text = "PLT" & [F56]

        End If

        'Competitor

        If [f55] >= [F56] Then

            ActiveSheet.Shapes("Eight").Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green

        End If

        

        If [F55 -(F56*.2)] <= [F56] Then

            ActiveSheet.Shapes("Eight").Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow

        End If

        If [F55 -(F56*.2)] > [F56] Then

            ActiveSheet.Shapes("Eight").Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red

        End If

        

        ActiveSheet.Shapes("Eight").TextFrame.Characters.Text = "PLT" & [f55]

End Sub

Open in new window

0
 
LVL 80

Expert Comment

by:byundt
ID: 20361011
For black text, you might use a statement like:
ActiveSheet.shapes("One").TextFrame.Characters.Font.ColorIndex=vbBlack      'vbBlack equals 1
0
 

Author Comment

by:tchristie33
ID: 20362349
Thanks.....is there any way to simplfy that code above
0
 
LVL 80

Expert Comment

by:byundt
ID: 20362563
You might try putting your shape names & cell addresses in variant arrays. You can then loop through those arrays and simplify the code into a single block.

The following code compiles, but hasn't been tested. You'll need to look at the Select Case block carefully, which assumes that all numbers are positive. I tried to mimic your latest code, but that varies considerably from the description in the original question. You'll note that I simplified the comparison by dividing through by cel1. Since the Select Case quits after the first matching expression, that simplified the logic.

Sub FormatShapes()
Dim vShapes As Variant, rg1 As Variant, rg2 As Variant
Dim cel1 As Range, cel2 As Range
Dim shp As Shape
Dim i As Long
vShapes = Array("One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight")
rg1 = Array("F8", "F7", "F24", "F23", "F40", "F39", "F56", "F55")
rg2 = Array("G8", "F8", "G24", "F24", "G40", "F40", "G56", "F56")
Application.ScreenUpdating = False
        For i = 0 To 7
            Set shp = ActiveSheet.Shapes(vShapes(i))
            Set cel1 = ActiveSheet.Range(rg1(i))
            Set cel2 = ActiveSheet.Range(rg2(i))
            shp.TextFrame.Characters.Text = "PLT" & [f8]
            shp.TextFrame.Characters.Font.Text = vbBlack
            If cel2 = "" Then
                shp.Fill.ForeColor.RGB = RGB(255, 255, 255) 'White
            Else
                Select Case cel1 / cel2
                Case Is <= 1    'Green
                    shp.Fill.ForeColor.RGB = RGB(0, 155, 0) 'Green
                Case Is <= 1.1  'Yellow
                    shp.Fill.ForeColor.RGB = RGB(250, 220, 0) 'Yellow
                Case Is > 1.1   'Red
                    shp.Fill.ForeColor.RGB = RGB(200, 0, 0) 'Red
                End Select
            End If
        Next
Application.ScreenUpdating = True
End Sub
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now