保护工作表时不能使用超链接而不允许用户选择锁定的单元格

Question

我有一个工作表,其中包含一组基于下拉菜单更改的动态超链接.只有具有下拉菜单的单元格才会被解锁.我取消选中"选择锁定的单元格",这样当我保护工作表时,用户只能选择下拉菜单.不幸的是,当我这样做时,超链接不再可用.

有谁知道如何解决这个问题？

UPDATE*

根据要求,我的动态超链接单元格的代码:

=IF(ISNA(MATCH(B4,'Data Sheet'!A2:A103,0)),"",HYPERLINK(VLOOKUP(B4,'Data Sheet'!A:S,7,FALSE),VLOOKUP(B4,'Data Sheet'!A:S,5,FALSE)&" - "&VLOOKUP(B4,'Data Sheet'!A:S,6,FALSE)))

1)单元格B4是用户选择特定选项的下拉列表.超链接根据此选择而更改.

2)'数据表'是一个单独的表格,其中包含数组中的所有参考数据.

这基本上说:B4中的值是否与我的数据图表中的第一列匹配？如果是这样,请使用VLOOKUP的超链接公式将相应的URL插入公式中.

Answer 1

这是我对设置和要求的理解:

设置

• 有一个带有下拉菜单的受保护工作表,它会更新包含VLOOKUP\HYPERLINK公式的其他单元格.

• 工作表中的所有单元格(不包括下拉菜单)都受到保护.

• 包含VLOOKUP\HYPERLINK公式的单元格的值可能等于www地址或空白,具体取决于下拉菜单的值.因此,所有超链接都指向网页或为空白.

• 工作表EnableSelection设置为xlUnlockedCells确定一旦工作表受到保护"只能选择未锁定的单元格".

要求 - 需要保护工作表以保护内容,包括VLOOKUP\HYPERLINK公式.

• 需要允许用户选择\仅激活未受保护的细胞,主要是出于美观原因并提供专业产品.

此解决方案使用以下资源

• 该HYPERLINK功能
• 一个UDF(用户定义的函数)
• 两个Public Variables和
• 这Worksheet_BeforeDoubleClick件事

当一个UDF被包裹成一个HYPERLINK函数它会导致该 每鼠标悬停在含有组合的单元时间 的公式HYPERLINK(UDF,[FriendlyName])的UDF被触发.

我们将使用a Public Variable来保存LinkLocation,稍后将根据用户决定的超链接使用.

第二个Public Variable设置LinkLocation上次更新的时间.

我们将模仿超链接"正常"激活的方式:

• 用户通过其选择单元格并单击所选单元格中的超链接.

• 相反,用户将悬停在单元格上的超链接(UDF将LinkLocation时间和时间输入公共变量)和DoubleClicks单元格(触发工作表事件以跟踪超链接,首先验证LinkLocation上次更新的时间以确保它仍然是实际的并清除LinkLocation变量).

首先,我们需要确保工作表中用于生成动态超链接的公式具有适当的结构:

假设当前的VLOOKUP\HYPERLINK公式具有以下结构:( 必须基于假设工作,因为未提供实际公式)

=IFERROR( HYPERLINK( VLOOKUP( DropDownCell , Range , Column, False ), FriendlyName ), "" )

我们需要将该公式更改为以下结构:

=IFERROR( HYPERLINK( UDF( VLOOKUP( DropDownCell , Range , Column, False ) ), FriendlyName ), "" )

以下程序负责修改公式结构,使其适用于所提出的解决方案.建议在名为"维护"的独立模块中复制两者.

Option Explicit

Private Sub Wsh_FmlHyperlinks_Reset()
Const kWshPss As String = "WshPssWrd"
Const kHypLnk As String = "HYPERLINK("
Dim WshTrg As Worksheet, rHyplnk As Range
Dim rCll As Range, sHypLnkFml As String
Dim sOld As String, sNew As String

    Rem Application Settings
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Rem Set & Unprotect Worksheet
    Set WshTrg = ActiveSheet
    WshTrg.Unprotect kWshPss

    Rem Find Hyperlink Formulas
    If Not (Rng_Find_Set(WshTrg.UsedRange, _
        rHyplnk, kHypLnk, xlFormulas, xlPart)) Then Exit Sub
    If rHyplnk Is Nothing Then Exit Sub

    Rem Add Hyperlinks Names
    For Each rCll In rHyplnk.Cells
        With rCll
            sHypLnkFml = .Formula
            sOld = "HYPERLINK( VLOOKUP("
            sNew = "HYPERLINK( Udf_HypLnkLct_Set( VLOOKUP("
                sHypLnkFml = Replace(sHypLnkFml, sOld, sNew)
            sOld = ", FALSE ),"
            sNew = ", FALSE ) ),"
                sHypLnkFml = Replace(sHypLnkFml, sOld, sNew)
            .Formula = sHypLnkFml
    End With: Next

    Rem Protect Worksheet
    WshTrg.EnableSelection = xlUnlockedCells
    WshTrg.Protect Password:=kWshPss

    Rem Application Settings
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub


Function Rng_Find_Set(rInp As Range, rOut As Range, _
    vWhat As Variant, eLookIn As XlFindLookIn, eLookAt As XlLookAt) As Boolean
Dim rFound As Range, sFound1st As String
    With rInp
        Set rFound = .Find( _
            What:=vWhat, After:=.Cells(1), _
            LookIn:=eLookIn, LookAt:=eLookAt, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        If Not (rFound Is Nothing) Then
            sFound1st = rFound.Address
            Do
                If rOut Is Nothing Then
                    Set rOut = rFound
                Else
                    Set rOut = Union(rOut, rFound)
                End If
                Set rFound = .FindNext(rFound)
            Loop While rFound.Address <> sFound1st
    End If:  End With
    Rem Set Results
    If Not (rOut Is Nothing) Then Rng_Find_Set = True
End Function

这些是公共变量和UDF.建议将它们复制到一个单独的模块中.

Option Explicit

Public psHypLnkLoct As String, pdTmeNow As Date

Public Function Udf_HypLnkLct_Set(sHypLnkFml As String) As String
    psHypLnkLoct = sHypLnkFml
    pdTmeNow = Now
End Function

并使用动态生成的超链接在受保护工作表的模块中复制此过程.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Now = pdTmeNow And psHypLnkLoct <> Empty Then
        ThisWorkbook.FollowHyperlink Address:=psHypLnkLoct, NewWindow:=True
    End If
End Sub

Answer 2

如果您愿意使用 VBA，则可以对相关工作表使用以下代码，这将复制超链接的单击事件，并尝试以目标的本机格式打开

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If InStr(1, Target.Formula, "HYPERLINK", vbTextCompare) > 0 Then

    On Error Resume Next

    Target.Hyperlinks(1).Follow (True)

    On Error GoTo 0

End If

End Sub

更新

我想我有一些解决办法。我从这里捏了一些代码，允许翻转动作触发一些vba。因此，假设您的链接位于单元格 A1 中。将您的链接更改为以下内容：

=IFERROR(HYPERLINK(MyMouseOverEvent("http://www.google.com"),"Hover"),"Hover")

您可以动态更改链接，前提是它返回一个字符串。现在创建一个新模块并粘贴以下内容：

Public Function MyMouseOverEvent(varLink As String)
    varResponse = MsgBox("Would you like to open link to: '" & varLink & "'?", vbYesNo, "Confirm")
    If varResponse = vbYes Then
        ActiveWorkbook.FollowHyperlink Address:=varLink, NewWindow:=True
    End If
End Function

唯一的缺点是它在悬停时而不是单击时触发代码，但是弹出框将允许用户决定是否要点击所述链接。我会继续关注它，看看是否可以找到点击的工作，但我认为它正在取得进展，因为即使在完全受到保护的情况下它也会触发。我正在使用 Excel 2010 如果有帮助的话。