Adding Hyperlink to Shape

Question

I'm trying to create an index by adding hyperlinks within an Excel Book to shapes on the cover sheet. This should be performed always before closing this workbook I'm initializing the shapes and then try to process them in a For/next procedure:

Sub beforeclose()

'initialize shapes
Set shpID = ThisWorkbook.Worksheets("Cover Sheet").Shapes(1)    'Introduction
Set shpDM = ThisWorkbook.Worksheets("Cover Sheet").Shapes(2)    'Cover Sheet
Set shpMD = ThisWorkbook.Worksheets("Cover Sheet").Shapes(3)    'Master Data
Set shpPD = ThisWorkbook.Worksheets("Cover Sheet").Shapes(4)    'Upload Portfolio Definition
Set shpPC = ThisWorkbook.Worksheets("Cover Sheet").Shapes(5)    'Upload Portfolio Classification
Set shpPA = ThisWorkbook.Worksheets("Cover Sheet").Shapes(6)    'Upload Portfolio Assignment
Set shpCD = ThisWorkbook.Worksheets("Cover Sheet").Shapes(7)    'Contract Data
Set shpBT = ThisWorkbook.Worksheets("Cover Sheet").Shapes(8)    'Business Transaction
Set shpCF = ThisWorkbook.Worksheets("Cover Sheet").Shapes(9)    'Best Estimate Cash Flow/Certainty Equivalent Cash Flow
Set shpCFU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(10)  'Upload Cash Flow
Set shpEPS = ThisWorkbook.Worksheets("Cover Sheet").Shapes(11)  'Exposure Period Split
Set shpEPSU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(12) 'Upload Exposure Period Split
Set shpNPR = ThisWorkbook.Worksheets("Cover Sheet").Shapes(13)  'Non Performance Risk
Set shpNPRU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(14) 'Upload Non Performance Risk
Set shpRA = ThisWorkbook.Worksheets("Cover Sheet").Shapes(15)   'Risk Adjustment
Set shpRAU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(16)  'Upload Risk Adjustment
Set shpER = ThisWorkbook.Worksheets("Cover Sheet").Shapes(17)   'Expected Subledger Results
Set shpSR = ThisWorkbook.Worksheets("Cover Sheet").Shapes(18)   'System Subledger Results
Set shpC = ThisWorkbook.Worksheets("Cover Sheet").Shapes(19)    'Calculation
Set shpRC = ThisWorkbook.Worksheets("Cover Sheet").Shapes(20)   'Results Comparison
Set shpR = ThisWorkbook.Worksheets("Cover Sheet").Shapes(21)    'Reconciliation
Set shpCS = ThisWorkbook.Worksheets("Cover Sheet").Shapes(22)   'Compare Source
Set shpCT = ThisWorkbook.Worksheets("Cover Sheet").Shapes(23)   'Compare Target
Set shpPRG = ThisWorkbook.Worksheets("Cover Sheet").Shapes(24)  'Coverage Units
Set shpPRGU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(25) 'Upload Coverage Units
Set shpTVE = ThisWorkbook.Worksheets("Cover Sheet").Shapes(26)  'Target Value
Set shpTVEU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(27) 'Upload Target Value
Set shpMA = ThisWorkbook.Worksheets("Cover Sheet").Shapes(28)   'Manual Adjustment
Set shpMAU = ThisWorkbook.Worksheets("Cover Sheet").Shapes(27)  'Upload Manual Adjustment
Set shpOP = ThisWorkbook.Worksheets("Cover Sheet").Shapes(27)   'Open Points

With ThisWorkbook.Worksheets("Cover Sheet")
    For lngIndex = .Index + 1 To ThisWorkbook.Worksheets.Count
        .Hyperlinks.Add
        Anchor:=shpid, _
        Address:="", _
        subaddress:="'"&thisworkbook.worksheets(lngindex).name&"'!A1", _
        Texttodisplay:=thisworkbook.worksheets(lngindex).name
    Next
End With

End Sub

Unfortunately I receive a syntax error when reaching the command Anchor!

Does anyone know how to solve this or what is wrong?

Thanks & Best Regards, Saied

Answer 1

Refresh Shapes

• It is assumed that there are enough shapes to cover all worksheets.

Option Explicit

Sub RefreshShapes()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets("Cover Sheet")
    
    Dim n As Long
    Dim wsName As String
    
    With ThisWorkbook.Worksheets("Cover Sheet")
        For n = .Index + 1 To .Parent.Worksheets.Count
            wsName = .Parent.Worksheets(n).Name
            ' I have used rectangles for the shapes and the upcoming
            ' 'TextToDisplay' does nothing, but the following line does:
            '.Shapes(n).TextEffect.Text = wsName
            .Hyperlinks.Add _
                Anchor:=.Shapes(n), _
                Address:="", _
                SubAddress:="'" & wsName & "'!A1", _
                TextToDisplay:=wsName
        Next n
    End With
    
End Sub