excel - 使用 =HYPERLINK-Formula 运行 Excel-Macro(通过 Selection_Change 事件)
问题描述
我想找到一种方法来动态地将超链接添加到我的 Excel-Sheet 并根据某些单元格内容运行宏。但是 HYPERLINK 公式和 Excel 中的常规超链接功能都不允许您直接从工作表调用宏。在线查找该问题将始终检索使用 Worksheet_FollowHyperlink 事件的选项。但是出于我的目的,此选项不适合,因为您要么必须将宏编写为喜欢“if target.range.address = A1 call macroA elseif target.cell = A2 call macro ....”等...这个解决方案是在我看来,这太静态了,因为您必须在 Worksheet_FollowHyperlink 代码中“硬连线”太多。此外,您必须通过 VBA 准备超链接以将地址和子地址更改为“”
=HYPERLINK() 公式看起来更有趣,因为您可以随时随地动态创建它。它也可以作为表格内的列函数正常工作,这正是我真正想要做的:在表格内有一列充满超链接,该表格将根据每个表格数据行中的其他内容运行具有某些给定参数的宏。这根本不适用于常规超链接,因为用户必须手动将它们复制并粘贴到每一行中。
遗憾的是,=HYPERLINK()-公式也没有提供直接使用给定参数运行宏的选项(至少我找不到)。它甚至不会触发 Worksheet_FollowHyperlink 事件,因此此时它似乎是一个死胡同。我在反复试验 + 互联网研究期间发现的有趣功能: =HYPERLINK("#TestMe", "Some text here...") 将打开 VBA 编辑器并直接跳转到我的 TestMe() 子。然而它不会被调用!
有什么办法可以解决这个问题?
- 在表数据列中动态创建超链接
- 根据数据行内容调用宏
解决方案
我的想法是使用 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
这个函数检查一个键是否在它被调用的那一刻被按下。来源是这个未解决的问题:单击单元格时如何运行代码?
上面代码的下一个演变现在看起来像这样:
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
将参数特征添加到超链接只是从这里迈出的一小步。
你的意见?
推荐阅读
- r - 列名中的 Unicode
- python - 从 100x100 的 pytorch 张量中获取 10x10 的补丁,其中圆环样式环绕边界
- sql - 嵌套 SQL 查询是原子的吗?
- reactjs - 已解决:系列数组更改后 React 顶点图表不呈现
- java - 在 Java 中使用线程处理数组元素
- prolog - 处理 SWI-Prolog 中的未知程序错误
- android - Android Studio 无法识别实现
- python - Why does the value produced is float and not integer?
- bing-maps - 必应地图 REST API 不返回正确的经纬度值
- css - 将复选框添加到绘图破折号的下拉列表中