Multiple shapes visible based of cell value

SCSabresfan

New Member
Joined
Sep 30, 2023
Messages
3
Office Version
  1. 2019
Platform
  1. Windows
I am trying to change the visibility of several shapes based off of the value in a row of cells.
Here are the details:
  • Shape Names are sequential
    • LineATop, LineBTop, LineCTop, etc
    • LineABottom, LineBBottom, LineCBottom, etc
  • Values to base the shape visibility is in g46, j46, m46, etc

I currently have a formula in cells g46, j46, m46, etc that returns either Top, Middle or Bottom based off another cell value. If g46 contains "Top" I want it to leave LineATop visible, but make LineAMiddle and LineABottom invisible. If g46 contains "Middle" I want it to leave LineAMiddle visible, but make LineATop and LineABottom invisible. If g46 contains "-", I want LineATop, LineAMiddle and LineABottom to all be invisible. I have tried a couple of other examples I found, but none of them allowed for multiple shapes to change visibility off one value. Can anyone help this VBA newbie???
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Here's a quick demo of one way to change multiple shapes on a sheet based on a single value. Here I've used cell G46 for the value, and this code looks at LineA.... shapes only. Please try it on a copy of your workbook.
VBA Code:
Option Explicit
Sub Test()
    Dim s As String, L As Object
    s = Worksheets("Sheet1").Range("G46")       '<-- *** Change to actual sheet name ***

    For Each L In ActiveSheet.Shapes
        If L.Name Like "LineA" & "*" Then
            If Not L.Name Like "*" & s & "*" Then
                L.Visible = False
            Else
                L.Visible = True
            End If
        End If
    Next L

End Sub
 
Upvote 0
I ended up overhauling my code after reviewing with some coworkers. Here is what I ended up with. It seems to slow excel down to a crawl. Is there a way to simplify the code? The lines and dimensions go from A to J and the objects are named similar. I only show A to C below for simplicity.

Private Sub Worksheet_Calculate()

'Visible Lines for flaw A
If Range("G42").Value = "-" Then
Shapes.Range(Array("LineABottom")).Line.Visible = msoFalse
Shapes.Range(Array("DimATop")).Line.Visible = msoFalse
Else
Shapes.Range(Array("LineABottom")).Line.Visible = msoTrue
Shapes.Range(Array("DimATop")).Line.Visible = msoTrue
End If

If Range("G54").Value = 1 Then
Shapes.Range(Array("DimABottom")).Line.EndArrowheadStyle = msoArrowheadNone
Shapes.Range(Array("DimABottom")).Line.BeginArrowheadStyle = msoArrowheadNone
Else
If Range("G54").Value = 2 Then
Shapes.Range(Array("DimABottom")).Line.EndArrowheadStyle = msoArrowheadTriangle
Shapes.Range(Array("DimABottom")).Line.BeginArrowheadStyle = msoArrowheadNone
Else
If Range("G54").Value = 3 Then
Shapes.Range(Array("DimABottom")).Line.EndArrowheadStyle = msoArrowheadNone
Shapes.Range(Array("DimABottom")).Line.BeginArrowheadStyle = msoArrowheadTriangle
Else
If Range("G54").Value = 4 Then
Shapes.Range(Array("DimABottom")).Line.EndArrowheadStyle = msoArrowheadTriangle
Shapes.Range(Array("DimABottom")).Line.BeginArrowheadStyle = msoArrowheadTriangle
End If
End If
End If
End If

'Visible Lines for flaw B
If Range("J42").Value = "-" Then
Shapes.Range(Array("LineBBottom")).Line.Visible = msoFalse
Shapes.Range(Array("DimBTop")).Line.Visible = msoFalse
Else
Shapes.Range(Array("LineBBottom")).Line.Visible = msoTrue
Shapes.Range(Array("DimBTop")).Line.Visible = msoTrue
End If

If Range("J53").Value = 0 Then
Shapes.Range(Array("DimBBottom")).Line.Visible = msoFalse
Else
Shapes.Range(Array("DimBBottom")).Line.Visible = msoTrue
End If

If Range("J54").Value = 1 Then
Shapes.Range(Array("DimBBottom")).Line.EndArrowheadStyle = msoArrowheadNone
Shapes.Range(Array("DimBBottom")).Line.BeginArrowheadStyle = msoArrowheadNone
Else
If Range("J54").Value = 2 Then
Shapes.Range(Array("DimBBottom")).Line.EndArrowheadStyle = msoArrowheadTriangle
Shapes.Range(Array("DimBBottom")).Line.BeginArrowheadStyle = msoArrowheadNone
Else
If Range("J54").Value = 3 Then
Shapes.Range(Array("DimBBottom")).Line.EndArrowheadStyle = msoArrowheadNone
Shapes.Range(Array("DimBBottom")).Line.BeginArrowheadStyle = msoArrowheadTriangle
Else
If Range("J54").Value = 4 Then
Shapes.Range(Array("DimBBottom")).Line.EndArrowheadStyle = msoArrowheadTriangle
Shapes.Range(Array("DimBBottom")).Line.BeginArrowheadStyle = msoArrowheadTriangle
End If
End If
End If
End If

'Visible Lines for flaw C
If Range("M42").Value = "-" Then
Shapes.Range(Array("LineCBottom")).Line.Visible = msoFalse
Shapes.Range(Array("DimCTop")).Line.Visible = msoFalse
Else
Shapes.Range(Array("LineCBottom")).Line.Visible = msoTrue
Shapes.Range(Array("DimCTop")).Line.Visible = msoTrue
End If

If Range("M53").Value = 0 Then
Shapes.Range(Array("DimCBottom")).Line.Visible = msoFalse
Else
Shapes.Range(Array("DimCBottom")).Line.Visible = msoTrue
End If

If Range("M54").Value = 1 Then
Shapes.Range(Array("DimCBottom")).Line.EndArrowheadStyle = msoArrowheadNone
Shapes.Range(Array("DimCBottom")).Line.BeginArrowheadStyle = msoArrowheadNone
Else
If Range("M54").Value = 2 Then
Shapes.Range(Array("DimCBottom")).Line.EndArrowheadStyle = msoArrowheadTriangle
Shapes.Range(Array("DimCBottom")).Line.BeginArrowheadStyle = msoArrowheadNone
Else
If Range("M54").Value = 3 Then
Shapes.Range(Array("DimCBottom")).Line.EndArrowheadStyle = msoArrowheadNone
Shapes.Range(Array("DimCBottom")).Line.BeginArrowheadStyle = msoArrowheadTriangle
Else
If Range("M54").Value = 4 Then
Shapes.Range(Array("DimCBottom")).Line.EndArrowheadStyle = msoArrowheadTriangle
Shapes.Range(Array("DimCBottom")).Line.BeginArrowheadStyle = msoArrowheadTriangle
End If
End If
End If
End If
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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
Back
Top