清单超链接点击跳转溯源

使用前需对溯源序号进行超链接赋予操作。

' 定义全局变量，记录第一次输入的工作表名称及筛选的列号
Private storedSheetName As String
Private storedFilterColumn As Long

' 用户可在此处填写目标工作表名称
Private Function GetTargetSheetName() As String
    GetTargetSheetName = "1." ' 替换为实际工作表名称，例如 "Sheet1" 或 "基础版"
End Function

' 用户可在此处填写筛选的列号
Private Function GetFilterColumn() As Long
    GetFilterColumn = 1 ' 替换为实际列号，例如 1 表示第一列
End Function

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim arr() As String
    Dim i As Long
    Dim wsBase As Worksheet
    Dim sText As String
    Dim refCell As Range
    Dim subAddr As String
    Dim dataRange As Range

    ' 检查或获取目标工作表名称
    If storedSheetName = "" Then
        storedSheetName = GetTargetSheetName
        If storedSheetName = "" Then
            storedSheetName = InputBox("请输入要筛选的数据所在工作表名称（例如：基础版）：", "设置工作表")
            If storedSheetName = "" Then Exit Sub
        End If
    End If

    ' 检查或获取筛选列号
    If storedFilterColumn = 0 Then
        storedFilterColumn = GetFilterColumn
        If storedFilterColumn = 0 Then
            Dim colInput As String
            colInput = InputBox("请输入数据区域中用于筛选的列号（例如：1 表示第一列）：", "设置筛选列")
            If colInput = "" Then Exit Sub
            If IsNumeric(colInput) Then
                storedFilterColumn = CLng(colInput)
                If storedFilterColumn <= 0 Then
                    MsgBox "列号必须为正整数！"
                    Exit Sub
                End If
            Else
                MsgBox "请输入有效的列号（数字）！"
                Exit Sub
            End If
        End If
    End If

    ' 获取超链接的目标地址（例如 "基础稿!A1"）
    subAddr = Target.SubAddress
    If subAddr <> "" Then
        On Error Resume Next
        Set refCell = Range(subAddr)
        On Error GoTo 0
        If Not refCell Is Nothing Then
            sText = CStr(refCell.Value)
        Else
            sText = Target.TextToDisplay
        End If
    Else
        sText = Target.TextToDisplay
    End If

    ' 若文本为空则退出
    If sText = "" Then Exit Sub

    ' 按“、”拆分字符串（支持多个序号的情况）
    arr = Split(sText, "、")
    For i = LBound(arr) To UBound(arr)
        arr(i) = Trim(arr(i))
    Next i

    ' 获取用户指定的工作表
    On Error Resume Next
    Set wsBase = ThisWorkbook.Worksheets(storedSheetName)
    On Error GoTo 0
    If wsBase Is Nothing Then
        MsgBox "找不到工作表 '" & storedSheetName & "'，请确认输入无误。"
        storedSheetName = "" ' 重置以便下次重新输入
        Exit Sub
    End If

    wsBase.Activate

    ' 使用 A1 单元格的当前区域作为数据区域
    On Error Resume Next
    Set dataRange = wsBase.Range("A1").CurrentRegion
    On Error GoTo 0
    If dataRange Is Nothing Then
        MsgBox "无法获取数据区域，请检查 A1 单元格所在区域是否正确。"
        Exit Sub
    End If

    ' 清除已有筛选
    If wsBase.AutoFilterMode Then wsBase.AutoFilterMode = False

    ' 对数据区域中的指定列进行筛选，使用拆分出的序号作为筛选条件
    With dataRange
        .AutoFilter Field:=storedFilterColumn, Criteria1:=arr, Operator:=xlFilterValues
    End With
End Sub