Alter Shape Colour across Multiple worksheets

[stirlingmw]

Morning All

I have a workbook with 28 Worksheets. 11 of these sheets have a shape border ("Rounded Rectangle 21") I am trying to change the colour of all of the 11 "Rounded Rectangle 21" shapes dependant on a selection within sheet1 cell H6 which either changes the border blue or red. The code I initially found I thought worked, but this now does not seem to be the case.

This code is:

If Not Intersect(Target, Range("H6")) Is Nothing Then
            If Target.Value = "UK SECRET" Or Target.Value = "SECRET" Then
            Sheet1.Shapes("Rounded Rectangle 21").Select
            Sheet2.Shapes("Rounded Rectangle 21").Select
            Sheet3.Shapes("Rounded Rectangle 21").Select
            Sheet4.Shapes("Rounded Rectangle 21").Select
            Sheet5.Shapes("Rounded Rectangle 21").Select
            Sheet6.Shapes("Rounded Rectangle 21").Select
            Sheet7.Shapes("Rounded Rectangle 21").Select
            Sheet8.Shapes("Rounded Rectangle 21").Select
            Sheet9.Shapes("Rounded Rectangle 21").Select
            Sheet10.Shapes("Rounded Rectangle 21").Select
            With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(255, 0, 0)
            .Transparency = 0
            End With
  else
  'same code with different RGB

I have tried this with both worksheet and selection change. I have even tried adding the with selection section to each shape select.

Any ideas?

Thanks

Steve

 

[Yongle]

I am wondering if your shape names are all correct
Your code is written to use the sheet codename rather than the sheet name - is that intentional?

Run macro below which creates a new sheet containing a list of all shapes on each sheet
The list includes each sheet's tab name and its vba codename

Do the shape names in your code EXACTLY match the names in list generated by the macro?

Sub LoopSheetsAndShapes()
    Dim sh As Worksheet, ws As Worksheet, shp As Shape
    Set ws = Worksheets.Add
    With ws.Range("A1:B1:C1")
        .Value = Split("TabName VBACodeName Shape")
        .EntireColumn.ColumnWidth = 30
    End With
    For Each sh In ThisWorkbook.Sheets
        For Each shp In sh.Shapes
            ws.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = Array(sh.Name, sh.CodeName, shp.Name)
        Next shp
    Next sh
End Sub

 

[Yongle]

OOPS
I spotted a minor error in the code after you looked at it. And amended it as follows

ws.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = Array(sh.Name, sh.CodeName, shp.Name)

 

[stirlingmw]

Yongle

Thanks for your reply, a very helpful piece of code.

I have run the code with your amend and the Rounded Rectangle 21 is annotate 11 times for the correct sheets. I have changed my code to reference the TabName instead of the VBACodeName, but nothing. The rectangles are selected on each sheet, but bot changed.

 

[stirlingmw]

I have achieved it another way. Rather than change all colours from a single cell selection on one sheet. when I open another worksheet, it is at this point the shape changes based on cell H6 value on sheet1.

It seems to work fine, just means I need to add that piece of code to each worksheet in turn.

Thanks for your help

 

[Yongle]

In that case, for future benefit:
- to select each shape requires the correct sheet to be active