Alter Shape Colour across Multiple worksheets

stirlingmw

Board Regular
Joined
Feb 18, 2013
Messages
75
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:
VBA Code:
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
 

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
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?

VBA Code:
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
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
OOPS
I spotted a minor error in the code after you looked at it. And amended it as follows
Rich (BB code):
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = Array(sh.Name, sh.CodeName, shp.Name)
 

stirlingmw

Board Regular
Joined
Feb 18, 2013
Messages
75
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

Board Regular
Joined
Feb 18, 2013
Messages
75
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

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
In that case, for future benefit:
- to select each shape requires the correct sheet to be active
 

Watch MrExcel Video

Forum statistics

Threads
1,127,820
Messages
5,627,087
Members
416,219
Latest member
TommyBoy79

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top