0

我想为我的工作簿中的形状分配一个宏，其中宏将一个相对超链接分配给调用它的形状。我尝试使用 application.caller 来获取形状的名称以分配超链接，但它不适用于所有形状，例如流程图形状。关于如何让它适用于所有形状的任何建议？对于工作表中的所有流程图形状，我收到运行时错误，未找到指定名称的项目。此代码适用于矩形等标准形状；但我的文档中需要流程图形状。

'Hyperlink to tab "control point log" using text in shape and cell values

Sub Controlpointhyperlink()
Dim rowvar as integer

ActiveSheet.Shapes(Application.Caller).Select
Selection.ShapeRange.Item(1).Name = "thisshape"

rowvar = Application.WorksheetFunction _
     .Match(ActiveSheet.Range("C2").Value & _
     ActiveSheet.Shapes("thisshape").TextFrame2.TextRange.Text, _
     Sheets("Control Point Log").Range("A1:A700"), 0)

With ActiveSheet
     .Hyperlinks.Add Anchor:= .Shapes("thisshape"), _
     Address:=ActiveWorkbook.Name & "#" & "'Control Point Log'!$C$" & rowvar
End With

End Sub
4

1 回答 1

0

问题出在您的代码中，您将每个形状的名称更改为“thisshape”，然后向其添加超链接。我试图更改您的代码，以便在宏的开头设置形状参考。然后宏正在使用这个引用。并且在 MATCH 函数调用之前添加了错误检查，因此如果该函数没有找到任何内容，则会显示消息框。我已经用包括流程图形状在内的不同形状对其进行了测试。希望这可以帮助。

Sub Controlpointhyperlink()

    Dim callerShapeName As String
    callerShapeName = Application.Caller

    With ActiveSheet
        Dim callerShape As Shape
        Set callerShape = .Shapes(callerShapeName)

        Dim findWhat As String
        findWhat = .Range("C2").Value & callerShape.TextFrame2.TextRange.Text

        Dim findWhere As Range
        Set findWhere = Sheets("Control Point Log").Range("A1:A700")

        Dim rowvar As Double

        Err.Number = 0
        On Error Resume Next

        rowvar = Application.WorksheetFunction.Match(findWhat, findWhere, 0)
        If (Err.Number = 1004) Then
            MsgBox "No match found for '" & findWhat & "' in range '" & findWhere.Address & "'."
            Exit Sub
        End If

        On Error GoTo 0

        Dim addressText As String
        addressText = ActiveWorkbook.Name & "#" & "'Control Point Log'!$C$" & rowvar
        .Hyperlinks.Add Anchor:=callerShape, Address:=addressText
    End With

End Sub
于 2013-04-25T07:57:30.850 回答