如何自动生成超链接、当单位格位置发生变化时自动更新超链接

dtxczjzmp

如何自动生成超链接、当单位格位置发生变化时自动更新超链接， 原来生成的超链接的顺序如2015年汇总中的表2：卢子、南村、黄展，并且与明细1和明细2的卢子、南村、黄展对应相互链接。
当2015年汇总中的表1的卢子、南村、黄展顺序变为黄展、南村、卢子时，则明细2中的黄展链接返回时却变成了光标定位在卢子了,出现了不相互对应，能否用vba解决吗？即当2015年汇总中的表1排序发生了变化，明细1，明细2中卢子、南村、黄展也自动更新对应吗？即卢子对卢子、南村对南村、黄展对黄展。具体如附件！请高手帮助，谢谢！ 如何批量生成、更新超链接.rar (18.92 KB, 下载次数: 8)

2018-5-6 08:45 上传

点击文件名下载附件

fenghuaxue

老哥解决这个了吗

天行道爷7

fenghuaxue 发表于 2023-4-3 17:51
老哥解决这个了吗

用这段代码吧，把“总览”和F3:F63的范围根据自己实际的表改一下就行了。
前两天刚整的

当“总览”表中，F3:F63与其余表有相同时，建立双向超级链接。

Sub CreateHyperlinks()
   
    Dim overviewSheet As Worksheet
    Set overviewSheet = ThisWorkbook.Sheets("总览")
   
    Dim cell As Range
    For Each cell In overviewSheet.Range("F3:F63")
        Dim cellValue As String
        cellValue = cell.value
        
        If Len(cellValue) > 0 Then
            Dim hyperlinkRange As Range
            Set hyperlinkRange = Nothing
            
            Dim sheet As Worksheet
            For Each sheet In ThisWorkbook.Sheets
                If sheet.Name <> overviewSheet.Name Then
                    Dim searchRange As Range
                    Set searchRange = sheet.UsedRange
                    
                    Dim foundCell As Range
                    Set foundCell = searchRange.Find(cellValue, LookIn:=xlValues, LookAt:=xlWhole)
                    
                    If Not foundCell Is Nothing Then
                        If hyperlinkRange Is Nothing Then
                            Set hyperlinkRange = cell
                        End If
                        
                        overviewSheet.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:= _
                            "'" & sheet.Name & "'!" & foundCell.Address, TextToDisplay:=cellValue
                           
                        sheet.Hyperlinks.Add Anchor:=foundCell, Address:="", SubAddress:= _
                            "'" & overviewSheet.Name & "'!" & cell.Address, TextToDisplay:=cellValue
                    End If
                End If
            Next sheet
            
            If Not hyperlinkRange Is Nothing Then
                hyperlinkRange.Select
            End If
        End If
    Next cell
   
End Sub