excel - 向形状添加超链接

Question

我正在尝试通过将 Excel 书中的超链接添加到封面上的形状来创建索引。这应该始终在关闭此工作簿之前执行，我正在初始化形状，然后尝试在 For/next 过程中处理它们:
子之前关闭()

'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

结束子
不幸的是，当我到达命令 Anchor 时收到语法错误!
有谁知道如何解决这个问题或有什么问题？
谢谢和最好的问候，
赛义德

Answer 1

刷新形状

假设有足够的形状覆盖所有工作表。

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