使用 =HYPERLINK-Formula 运行 Excel-Macro（通过 Selection_Change 事件）

Question

我想找到一种方法来动态地将超链接添加到我的 Excel-Sheet 并根据某些单元格内容运行宏。但是 HYPERLINK 公式和 Excel 中的常规超链接功能都不允许您直接从工作表调用宏。在线查找该问题将始终检索使用 Worksheet_FollowHyperlink 事件的选项。但是出于我的目的，此选项不适合，因为您要么必须将宏编写为喜欢“if target.range.address = A1 call macroA elseif target.cell = A2 call macro ....”等...这个解决方案是在我看来，这太静态了，因为您必须在 Worksheet_FollowHyperlink 代码中“硬连线”太多。此外，您必须通过 VBA 准备超链接，将地址和子地址更改为“”，以避免不必要的选择更改或 excel 中的错误弹出窗口（因为找不到某些地址）。

=HYPERLINK() 公式看起来更有趣，因为您可以随时随地动态创建它。它也可以作为表格内的列函数正常工作，这正是我真正想要做的：在表格内有一列充满超链接，该表格将根据每个表格数据行中的其他内容运行具有某些给定参数的宏。这根本不适用于常规超链接，因为用户必须手动将它们复制并粘贴到每一行中。

遗憾的是，=HYPERLINK()-公式也没有提供直接使用给定参数运行宏的选项（至少我找不到）。它甚至不会触发 Worksheet_FollowHyperlink 事件，因此此时它似乎是一个死胡同。 我在反复试验 + 互联网研究中发现的有趣功能： =HYPERLINK("#TestMe", "Some text here...") 将打开 VBA 编辑器并直接跳转到我的 TestMe() 子。然而它不会被调用！

有什么办法可以解决这个问题？

• 在表数据列中动态创建超链接
• 根据数据行内容调用宏

Answer 1

我的想法是使用 Workbook_SheetSelectionChange 事件来监控是否选择了具有 HYPERLINK 公式的单元格，结果非常好。

我的代码的第一次修订：

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Dim MacroName As String
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Formula Like "=HYPERLINK(LEFT(""|""*""|"",*),*)" Then
        MacroName = Split(Target.Formula, """|""")(1)
        MacroName = VBA.Trim(Replace(MacroName, "&", ""))
        MacroName = Sh.Evaluate(MacroName)
        
        Application.Run Macro
    End If

End Sub

它需要有一个具有以下公式的单元格： =HYPERLINK(LEFT("|" & A1 & "|", 0), "Run Macro in A18") 其中单元格 A1 包含我要运行的某个宏的名称。宏的名称也可以硬连线在公式中。

注意：需要 LEFT(..., 0) 部分，因此在单击超链接时，超链接的地址将显示为空。否则它会因为找不到目标而弹出错误提示。

不幸的是，当使用返回键、制表键或箭头键选择单元格时，SelectionChange 事件也会触发。要过滤掉这些，您将需要以下 API 调用：

Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vkey As Integer) As Boolean

此函数检查在调用它的那一刻是否按下了某个键。 来源是这个未解决的问题：How to run code when clicking a cell?

上面代码的下一个演变现在看起来像这样：

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If GetAsyncKeyState(vbKeyTab) _
         Or GetAsyncKeyState(vbKeyReturn) _
         Or GetAsyncKeyState(vbKeyDown) _
         Or GetAsyncKeyState(vbKeyUp) _
         Or GetAsyncKeyState(vbKeyLeft) _
         Or GetAsyncKeyState(vbKeyRight) _
         Or Target.Cells.Count > 1 _
         Or VBA.TypeName(Sh) <> "Worksheet" _
    Then Exit Sub
    
    Dim Macro As String
    
    If Target.Formula Like "=HYPERLINK(LEFT(""|""*""|"",*),*)" Then
        Macro = Split(Target.Formula, """|""")(1)
        Macro = VBA.Trim(Replace(Macro, "&", ""))
        Macro = Sh.Evaluate(Macro)
        
        Application.Run Macro
    End If

End Sub

现在这将过滤掉所有由键盘命令完成的选择更改。 然而，还有一步要采取，因为我必须注意到，在更改超链接上方或左侧的单元格并按回车键或制表键时似乎存在缺陷。由于某种原因，GetAsyncKeyState 将为两个键返回 false，因此我的代码将继续运行。

所以对于这些情况，我不得不创造一些肮脏的工作。您将需要 Workbook_SheetChange 事件来设置一个临时禁用 Workbook_SheetSelectionChange 事件的开关。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    RecentSheetChange = True
    Application.OnTime VBA.DateAdd("s", 0.1, Now), "ResetRecentSheetChange"
End Sub

'Code inside a new module:

Option Explicit
Option Private Module

Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vkey As Integer) As Boolean
Public RecentSheetChange As Boolean

Private Sub ResetRecentSheetChange()
    RecentSheetChange = False
End Sub

ThisWorkbook 中的最终代码现在如下所示：

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If GetAsyncKeyState(vbKeyTab) _
         Or GetAsyncKeyState(vbKeyReturn) _
         Or GetAsyncKeyState(vbKeyDown) _
         Or GetAsyncKeyState(vbKeyUp) _
         Or GetAsyncKeyState(vbKeyLeft) _
         Or GetAsyncKeyState(vbKeyRight) _
         Or Target.Cells.Count > 1 _
         Or VBA.TypeName(Sh) <> "Worksheet" _
         Or RecentSheetChange _
    Then Exit Sub
    
    Dim Macro As String
    
    If Target.Formula Like "=HYPERLINK(LEFT(""|""*""|"",*),*)" Then
        Macro = Split(Target.Formula, """|""")(1)
        Macro = VBA.Trim(Replace(Macro, "&", ""))
        Macro = Sh.Evaluate(Macro)
        
        Application.Run Macro
    End If

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    RecentSheetChange = True
    Application.OnTime VBA.DateAdd("s", 0.1, Now), "ResetRecentSheetChange"
End Sub

向超链接添加参数特征只是从这里迈出的一小步。

你的想法？