根据单元格值将数据添加到行时创建超链接

Question

我有以下要求：

使用 Col D 中的地址在 Col A 中添加超链接（Web Link），保留 Col A 显示文本和工具提示 Col D 文件路径地址。
使用 Col E、Col A 和 Col B（用于本地网络位置）中的文件路径地址在 Col C 中添加超链接。保留Col显示文字和Tooltip Col E、Col A和Col B文件路径地址。文件命名遵循此序列“Data-002 Rev 00.pdf”。
在 Col F“查看本地文件”中添加超链接，在 Col 中添加相同的工具提示。
如果 Col E 为空白，Col C 不应在 Col C 中添加超链接，应保留 Col C 的字体样式并在 Col F 中添加文本“未找到文件”。
刷新table时保留所有超链接，只为没有超链接的单元格创建新超链接。

由于我是从另一个table中提取数据，所以上面的文档顺序可能会改变，例如“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

Answer 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

根据单元格值将数据添加到行时创建超链接

Create Hyperlink, when data is added to row, based on cell value

excel

vba

hyperlink