当根据单元格值为每一行添加其他数据时，VBA 创建超链接

Posted 2023-03-25

【中文标题】当根据单元格值为每一行添加其他数据时，VBA 创建超链接

【英文标题】：Create Hyperlink, when data is added to row, based on cell value

【发布时间】：2022-01-16 18:19:29

【问题描述】：

大家好，提前感谢您的帮助。

我对 VBA 有以下要求：

使用Col D中的地址（Web Link）在Col A中添加超链接，保留Col A显示文本和工具提示Col D文件路径地址。

使用 Col E、Col A 和 Col B 中的文件路径地址在 Col C 中添加超链接（用于本地网络位置）。保留 Col C 显示文本和 Tooltip Col E、Col A 和 Col B 文件路径地址。文件命名始终遵循“Data-002 Rev 00.pdf”这个顺序。

在 Col F "View File Local" 中添加超链接，在 Col C 中添加相同的工具提示。

如果 Col E 为空 Col C 不应在 Col C 中添加超链接，应保留 Col C 的字体样式并在 Col F 中添加文本“未找到文件”。

在刷新表格时保留所有超链接，并且只为没有超链接的单元格创建新的超链接。

由于我是从另一个表中提取数据，上面的文档顺序可能会改变，例如刷新数据时“Data-002”可能在第二行，因为刷新后会添加“Data-001” .

不知道刷新后VBA超链接是否会保留原来的链接地址，如果是，则不再需要第5项要求。

我的最终用户倾向于删除 Col F 中的硬编码超链接公式，我希望修复超链接，这样他们就不能错误地删除或修改，或者最坏的情况是删除或删除超链接。

目前，我确实有下面的代码，它实际上完成了大部分 Hyperlink.Add，但它一直在为工作簿中可用的整个行和工作表做，这使 Excel 文件冻结。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rColA As Range
Dim rColName As String
Dim LastRow As Long
Dim rColC As Range
Dim rColName1 As String

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set rColA = Range("A1:A" & LastRow)

If Intersect(Range("A1:A" & LastRow), Target) Is Nothing Then Exit Sub

Application.EnableEvents = False

For Each rColA In rColA

     If rColA.Column = 1 Then
        rColName = rColA.Value2
        rColA.Parent.Hyperlinks.Add _
        Anchor:=Cells(rColA.Row, 1), _
        Address:=Cells(rColA.Row, 4), _
        TextToDisplay:=rColA
        rColA.Font.Size = 10
        rColA.Font.Underline = False
     End If

Next rColA

Set rColC = Range("C1:C" & LastRow)

If Intersect(Range("C1:C" & LastRow), Target) Is Nothing Then Exit Sub

For Each rColC In rColC
  
   If Cells(rColC.Row, 5) <> "" Then

      If rColC.Column = 3 Then
         rColName1 = rColC.Value2
         rColC.Parent.Hyperlinks.Add _
         Anchor:=Cells(rColC.Row, 3), _
         Address:=Cells(rColC.Row, 5) & Cells(rColC.Row, 1) & " Rev " & Cells(rColC.Row, 2) & ".pdf", _
        TextToDisplay:=rColName1
        rColC.Font.Size = 10
        rColC.Font.Underline = False
  
   End If

End If

Next rColC

Application.EnableEvents = True

End Sub

非常感谢任何帮助。提前谢谢你。

谢谢， 米尔克

【参考方案1】：

试试这个：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim LastRow As Long, rng As Range, c As Range, addr
    
    LastRow = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
    
    On Error GoTo haveError
    
    'see if any cells of interest have changed
    Set rng = Application.Intersect(Target, Me.Range("A1:A" & LastRow & ",C1:C" & LastRow))
    If Not rng Is Nothing Then
        Application.EnableEvents = False
        For Each c In rng.Cells
            Select Case c.Column  'select link address based on column
                Case 1: addr = c.EntireRow.Columns("D")
                Case 3: addr = Cells(c.Row, "E") & Cells(c.Row, "A") & " Rev " & Cells(c.Row, "B") & ".pdf"
            End Select
            c.Parent.Hyperlinks.Add Anchor:=c, Address:=addr, TextToDisplay:=c.Value2
            c.Font.Size = 10
            c.Font.Underline = False
        Next c
        Application.EnableEvents = True
    End If
    
    Exit Sub 'don't run into the error handler
    
haveError:
    Application.EnableEvents = True 'make sure an error doesn't leave events turned off
End Sub

编辑：我认为这可能更接近您想要的。将每一行视为一个单元会更容易，而不是尝试跟踪每个单元格的更改并仅更新某些链接。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim LastRow As Long, rng As Range, rw As Range, addr, txt
    
    LastRow = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
    
    On Error GoTo haveError
    
    'see if any cells of interest have changed
    Set rng = Application.Intersect(Target.EntireRow, Me.Range("A1:F" & LastRow))
    If Not rng Is Nothing Then
        Application.EnableEvents = False
        
        'loop over changed rows
        For Each rw In rng.Rows
            
            Me.Hyperlinks.Add anchor:=rw.Columns("A"), _
                     Address:=rw.Columns("D").Value, _
                     TextToDisplay:=rw.Columns("A").Value2
            
            Me.Hyperlinks.Add anchor:=rw.Columns("C"), _
                     Address:=rw.Columns("E") & rw.Columns("A") & " Rev " & rw.Columns("B") & ".pdf", _
                     TextToDisplay:=rw.Columns("C").Value2
            
            If Len(rw.Columns("E").Value) > 0 Then
                Me.Hyperlinks.Add anchor:=rw.Columns("F"), _
                     Address:="whatever is the path here", _
                     TextToDisplay:="View file local"
            Else
                rw.Columns("E").Value = "File not found"
            End If
            
            With rw.Range("A1,C1,F1") 'Range() is *relative* to rw
                .Font.Size = 10
                .Font.Underline = False
            End With
        
        Next rw
        
        Application.EnableEvents = True
    End If
    
    Exit Sub 'don't run into the error handler
    
haveError:
    Application.EnableEvents = True 'make sure an error doesn't leave events turned off
End Sub

【讨论】：

非常感谢蒂姆，如果不是太多的话.. 我们可以在 Col F 中添加一个超链接并将文本显示为“打开文件位置”，它将使用 Col 导航到文档文件位置E 文件夹路径，如果 Col E 不为空，否则如果 Col E 为空，则添加显示文本“找不到文件”。您可能会想，如果我已经拥有指向文档本身的超链接，那么为什么我需要打开文件位置，在文档的同一文件夹中还有用户需要检查的支持文档。提前感谢蒂姆。干杯！！

非常感谢！