楼主
kevinchengcw |
Q: 如何用vba代码实现目录中的超链接不受工作表改名及行列变动影响？
A: 利用单元格批注可以曲线实现这一目标，代码解释如下：
模块中的代码：
- Sub test() '本程序用于将超链接中的源单元格和目标单元格添加上批注,用批注来记录相关信息
- Dim HLK As Hyperlink, Arr
- For Each HLK In Worksheets("目录").Hyperlinks '循环目录表中的各个链接
- Arr = Split(HLK.SubAddress, "!") '提取链接地址(本工作簿内的),并拆分放入数组
- With HLK.Parent '为链接所在单元格写入批注,内容为目标单元格所在工作表的codename,这样不受工作表改名影响
- .ClearComments
- .AddComment Worksheets(Replace(Arr(0), "'", "")).CodeName
- End With
- With Range(HLK.SubAddress) '对于目标单元格则写入目录表的codename和单元格地址,以"!"分隔,方便拆分
- .ClearComments
- .AddComment HLK.Parent.Parent.CodeName & "!" & HLK.Parent.Address
- End With
- Next HLK
- End Sub
Thisworkbook中代码：
- Private Sub Workbook_SheetActivate(ByVal Sh As Object) '当工作表激活时执行下述语句
- Dim HLK As Hyperlink, Arr, Str$, Dic As Object, WS As Worksheet
- If Sh.CodeName = "Sheet1" Then '判断是不是目录工作表(即使目录工作表改名也可以继续有效,因为是检测codename
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目,用于装载工作表名与codename对应关系
- For Each WS In Worksheets '循环提取各表名和codename
- Dic.Add WS.CodeName, WS.Name
- Next WS
- For Each HLK In Sh.Hyperlinks '循环各个链接
- Arr = Split(HLK.SubAddress, "!") '获取工作簿内地址并拆分放入数组
- Arr(0) = Dic(HLK.Parent.Comment.Text) '更新工作表名
- HLK.SubAddress = Join(Arr, "!") '组合后更新地址
- Next HLK
- Set Dic = Nothing '清空字典项目
- End If
- End Sub
- Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) '单元格选择变更时执行下述代码
- Dim Cmt As Comment, Arr, Str$, Dic As Object, WS As Worksheet
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- For Each WS In Worksheets '循环添加工作表名与codename对应关系
- Dic.Add WS.CodeName, WS.Name
- Next WS
- If Sh.CodeName <> "Sheet1" Then '如果不是目录表,则
- For Each Cmt In Sh.Comments '循环各个批注
- If Cmt.Text Like "*!*" Then '如果批注符合特征(该特征可进一步修改以进一步符合实际使用中情况)
- Arr = Split(Cmt.Text, "!") '拆分放入数组
- With Worksheets(Dic(Arr(0))) '对于codename所对应的工作表
- Str = .Range(Arr(1)).Text '提取单元格文字
- .Range(Arr(1)).ClearContents '清除现有内容
- .Hyperlinks.Add .Range(Arr(1)), "", "'" & Dic(Cmt.Parent.Parent.CodeName) & "'!" & Cmt.Parent.Address, Str, Str '重新添加链接地址
- End With
- End If
- Next Cmt
- End If
- Set Dic = Nothing '清空字典项目
- End Sub
附示例文件。
 智能超链接.rar
|
haodongxi好东西就是不会用