Create macro that assigns value in a cell to Shape

[bobshah2010]

Hi Guys!

I'm having some trouble assigning a name to a shape via a macro.

Right now my macro is creating a list of visible sheets, and then creating an equal amount of shapes onto the worksheet.

I would like my macro to assign the shapes created with the value that is in the list created earlier (of all visible sheets). Ideally this shape should be linked i.e. "=$A$1" etc, not just named.

The next step that i have in mind is to assign these shapes with a macro - so that once you click on the shape it will re-direct you to the respective sheet name you clicked on.

This is the macro that i have used to assign shapes manually before:

Sub SheetLink()Application.GoToReference:= Worksheets (ActiveSheet.DrawingObjects(Application.Caller).Text).Range("A1")
End Sub

This is what i have so far:

Sub SheetNames()    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = ActiveSheet
    Dim sq As Shape
    Dim rngRange As Range
    Dim Shp As Shape
    i = 1
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set rngRange = Sheets(1).Range("A1")
    ws1.Columns(1).Insert
    For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            ws1.Cells(i, 1) = ws.Name
            Set sq = ws1.Shapes.AddShape(1, 50, 50, 100, 100)
            
            'Selection.Formula = ws1.Cells(i, 1)
            i = i + 1
        End If
    Next ws
'    For Each Shp In ActiveSheet.Shapes
'        Shp.Select
'        Selection.Formula = ws1.Columns(1)
'    Next
End Sub

Please ignore some of the commented areas. I've been trying different things, but none seem to be working.

To provide some context, i've previously been creating shapes and linking them to sheet names manually before. (i.e would copy and paste each sheet name into a column on a separate sheet. Then creating a few shapes and assigning the above macro to the shape.

I'm looking at automating this process, essentially creating a navigation page.

 

[mjbeam]

Have you tried:

    For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            ws1.Cells(i, 1) = ws.Name
            Set sq = ws1.Shapes.AddShape(1, 50, 50, 100, 100)
            
            sq.Name = ws1.Cells(i, 1)
            i = i + 1
        End If
    Next ws

 

[bobshah2010]

Hey mjbeam,

I just tried it - It creates shape however does not link the shapes to the list created - unless i did something wrong. I tried recording the macro and i think i need to use Selection.Formula function.

thanks

 

[JoeMo]

Does this do what you want? Run it with the sheet you want the shapes on active.

Sub test()
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            ws1.Cells(i + 1, 1) = ws.Name
            'change the multiplier in next line to space the rectangles to suit
            ws1.Shapes.AddShape(1, 50 + i * 10, 50 + i * 10, 100 + i * 10, 100 + i * 10).Select
            Selection.Formula = "=A" & i + 1
            i = i + 1
        End If
    Next ws
    End Sub

 

[bobshah2010]

Oh wow! thanks JoeMo! works really well.

I wasn't that far off from getting it I think ahaha.

Do you think it is straight forward to assign the following Macro to each of the shapes via a macro? Let me know if this sounds a bit confusing for you.

Sub ShapeLink()    Application.Goto Reference:=Worksheets(ActiveSheet.DrawingObjects(Application.Caller).Text).Range("A1")
End Sub

something similar to this:

Sub test()
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            ws1.Cells(i + 1, 1) = ws.Name
            'change the multiplier in next line to space the rectangles to suit
            ws1.Shapes.AddShape(1, 50 + i * 10, 50 + i * 10, 100 + i * 10, 100 + i * 10).Select
            Selection.Formula = "=A" & i + 1
            OnAction = "'" & ActiveWorkbook.Name & "ShapeLink"
            i = i + 1
        End If
    Next ws
    End Sub

^the above however doesn't work

 

[bobshah2010]

bump

 

[JoeMo]

Oh wow! thanks JoeMo! works really well.

I wasn't that far off from getting it I think ahaha.

Do you think it is straight forward to assign the following Macro to each of the shapes via a macro? Let me know if this sounds a bit confusing for you.

Sub ShapeLink()    Application.Goto Reference:=Worksheets(ActiveSheet.DrawingObjects(Application.Caller).Text).Range("A1")
End Sub

something similar to this:

Sub test()
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            ws1.Cells(i + 1, 1) = ws.Name
            'change the multiplier in next line to space the rectangles to suit
            ws1.Shapes.AddShape(1, 50 + i * 10, 50 + i * 10, 100 + i * 10, 100 + i * 10).Select
            Selection.Formula = "=A" & i + 1
            OnAction = "'" & ActiveWorkbook.Name & "ShapeLink"
            i = i + 1
        End If
    Next ws
    End Sub

^the above however doesn't work

How about this:

Sub test()
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            ws1.Cells(i + 1, 1) = ws.Name
            'change the multiplier in next line to space the rectangles to suit
            ws1.Shapes.AddShape(1, 50 + i * 10, 50 + i * 10, 100 + i * 10, 100 + i * 10).Select
            With Selection
              .Formula = "=A" & i + 1
              .OnAction = "ActivateSheet"
              End With
            i = i + 1
        End If
    Next ws
    End Sub
Sub ActivateSheet()
Dim shp As Shape
Set shp = ActiveSheet.Shapes(Application.Caller)
s = shp.TextFrame.Characters.Text
Sheets(s).Select
End Sub

 

[bobshah2010]

Hey Joe,

I tried that, i'm getting a random error :s

Run-time error '-2147352571 (80020005)':
The item with the specified name wasn't found.

and it points to this line (in bold):

Sub ActivateSheet()
Dim shp As Shape
[B]Set shp = ActiveSheet.Shapes(Application.Caller)[/B]
s = shp.TextFrame.Characters.Text
Sheets(s).Select
End Sub

 

[JoeMo]

Hey Joe,

I tried that, i'm getting a random error :s

Run-time error '-2147352571 (80020005)':
The item with the specified name wasn't found.

and it points to this line (in bold):

Sub ActivateSheet()
Dim shp As Shape
[B]Set shp = ActiveSheet.Shapes(Application.Caller)[/B]
s = shp.TextFrame.Characters.Text
Sheets(s).Select
End Sub

Am I correct in assuming the active sheet is the one that contains the rectangles the ActivateSheet macro is assigned to and that you have clicked one of the rectangles rather than try to run the ActivateSheet macro directly? If not, I probably don't understand what you want to do.

 

[bobshah2010]

Apologies Joe, I tried again and it worked!

Thank you so much, you were really helpful!