根據單元格值為每行添加附加資料時，VBA創建超鏈接

大家好 在此先感謝您的幫助。

我對 VBA 有以下要求：

1. 使用 Col D 中的地址（Web 鏈接）在 Col A 中添加超鏈接，保留 Col A 顯示文本和工具提示 Col D 檔案路徑地址。

2. 使用 Col E、Col A 和 Col B 中的檔案路徑地址在 Col C 中添加超鏈接（用于本地網路位置）。保留 Col C 顯示文本和 Tooltip Col E、Col A 和 Col B 檔案路徑地址。檔案命名始終遵循“Data-002 Rev 00.pdf”這個序列。

3. 在 Col F“查看本地檔案”中添加超鏈接，在 Col C 中添加相同的工具提示。

4. 如果 Col E 為空 Col C 不應在 Col C 中添加超鏈接，而應保留 Col C 的字體樣式并在 Col F 中添加文本“找不到檔案”。

5. 重繪 表格時保留所有超鏈接，只為沒有超鏈接的單元格創建新的超鏈接。

由于我是從另一個表中提取資料，所以上面的檔案順序可能會發生變化，例如“Data-002”可能在資料重繪 時位于第 2 行，因為重繪 后將添加“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

很感謝任何形式的幫助。先感謝您。

謝謝，米爾科

uj5u.com熱心網友回復：

試試這個：

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

標籤：擅长 vba 超链接

上一篇：比較多個資料框列以列出

下一篇：ExcelVBA隱藏行