Change Shape's Color upon entries in a Cell

Hi DesCmCn and welcome to ExcelForum.com,

When you post code, you need 'code tags', otherwise the moderators won't let us answer your questions. See the forum rules for instructions: http://www.excelforum.com/forum-rule...rum-rules.html


The following code (tested and working in Excel 2003) may help you:

Option Explicit

Public Sub GetSelectedShapeName()

  Dim sShapeName As String
  
  On Error Resume Next
  sShapeName = Application.Selection.Name
  If Err.Number = 0 Then
    MsgBox "The name of the Shape selected Is '" & sShapeName & "'."
  Else
    MsgBox "There was no Shape selected."
  End If
  
  On Error GoTo 0
End Sub

Public Sub RenameSelectedShapeName()

  Dim sShapeName As String
  Dim sNewShapeName As String
  
  sNewShapeName = "xxxx"
  
  On Error Resume Next
  sShapeName = Application.Selection.Name
  If Err.Number = 0 Then
    Application.Selection.Name = sNewShapeName
    MsgBox "The Old name of the Shape selected: '" & sShapeName & "'." & vbCrLf & _
           "The New name of the Shape selected: '" & Application.Selection.Name & "'."
  Else
    MsgBox "There was no Shape selected."
  End If
  
  On Error GoTo 0
End Sub

Sub ColorChangeStar()
  'This changes the color of a specific Shape Name based on the value in cell 'C6' of the sheet the shape is in
  '
  'NOTE: Excel 2003 doesn't support 'Themecolor' and 'TintAndShade'
  'ThemeColor reference:  http://www.excelbanter.com/showthread.php?t=250015

  Dim wks As Worksheet
  Dim sSheetName As String

  Dim sShapeName As String
  sShapeName = "xxxx"
    

  For Each wks In ActiveWorkbook.Worksheets
    
    If wks.Range("C6").Value = "Yes" Then
      wks.Shapes(sShapeName).Fill.ForeColor.RGB = vbYellow
      'wks.Shapes(sShapeName).Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent6   'NOT TESTED
      'wks.Shapes(sShapeName).Fill.ForeColor.TintAndShade = -0.249977111117893         'NOT TESTED
    Else
      wks.Shapes(sShapeName).Fill.ForeColor.RGB = vbGreen
      'wks.Shapes(sShapeName).Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent6   'NOT TESTED
      'wks.Shapes(sShapeName).Fill.ForeColor.TintAndShade = -0.249977111117893         'NOT TESTED
    End If
    
  Next wks

End Sub

Lewis

Thank you LJMetzger,

My apologies for the mistake, this seemed to have gone over my head. I edited the post before.

I will try to implement your suggestion, as I have not been able to make it work yet.