tchristie33
asked on
Excel VB Shapes: Change for and text based upon certain variables
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-Reliab ility").Se lect
ActiveSheet.Shapes("One"). Fill.ForeC olor.RGB = RGB(255, 0, 0)
Shapes("One").TextFrame.Te xtRange.Te xt = a1
End Sub
Sub Shape()
Sheets("Performance-Reliab
ActiveSheet.Shapes("One").
Shapes("One").TextFrame.Te
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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
If that won't work, are there any other shapes on the worksheet?
What exactly are the names of the eight shapes?
Brad
ASKER
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
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
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
ASKER
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]
ActiveSheet.Shapes("One").
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
For black text, you might use a statement like:
ActiveSheet.shapes("One"). TextFrame. Characters .Font.Colo rIndex=vbB lack 'vbBlack equals 1
ActiveSheet.shapes("One").
ASKER
Thanks.....is there any way to simplfy that code above
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.T ext = "PLT" & [f8]
shp.TextFrame.Characters.F ont.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
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
For i = 0 To 7
Set shp = ActiveSheet.Shapes(vShapes
Set cel1 = ActiveSheet.Range(rg1(i))
Set cel2 = ActiveSheet.Range(rg2(i))
shp.TextFrame.Characters.T
shp.TextFrame.Characters.F
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
End Sub
ASKER