VBA Create Hyperlink when additional data is added for each row based on cell value-CodePudding

Hi All Thank you in advance for any help.

I have the below requirements for the VBA:

Add hyperlink in Col A using address in Col D (Web Link), retain Col A display text and tooltip Col D file path address.
Add hyperlink in Col C using file path address in Col E, Col A and Col B (for Local network location). Retain Col C display text and Tooltip Col E, Col A and Col B file path address. The file naming consistently follows this sequence "Data-002 Rev 00.pdf".
Add hyperlink in Col F "View File Local", same tooltip in Col C.
If Col E is blank Col C should not Add hyperlink in Col C and should retain the font style of Col C and Add text in Col F "File Not Found".
Retain all the Hyperlinks upon refresh of the table and only create new hyperlinks for the cell not having hyperlinks.

Since I am extracting the data from another table, the above order of documents might change, example "Data-002" might be in the 2nd Row when the data is refreshed because “Data-001” will be added after the refresh.

I don't know whether the VBA hyperlinks will retain its original linked address upon refresh, if yes, then Item 5 requirement is not required anymore.

My End-user tend to delete the hardcoded hyperlink formulas in Col F, I want the hyperlink fixed so they cannot delete or modify by mistake or worst deleted or removed the hyperlinks.

Currently, I do have the below code which actually do most of the Hyperlink.Add but it keeps doing for the entire rows and sheets available in the workbook which keeps the excel file freeze.

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

Any help is very much appreciated. Thank you in advance.

Thanks, Mielkew

CodePudding user response：

Try this:

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

EDIT: I think this is probably closer to what you want. It'd easier just to treat each row as a unit, rather than try to track changes per-cell and only update certain links.

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