Hyperlink using a column as reference.

E

eli_m

Board Regular
Joined
Jun 2, 2022
Messages
129
Office Version
  1. 365
Platform
  1. Windows
Hi,

My data looks something like this:

ABC
1Name:Date Of Birth:Reference:
2SMITH, John12/03/1988K3472
3JONES, Kayla27/04/1962K7895
4RUSS, Tim08/07/2022


I want the names (A2:A4) to be hyperlinks using the data from Column C. The link to the website:
www.test.com/reference/COLUMN-C-VALUE-HERE

So, for A2 I want SMITH, John hyperlink to www.test.com/reference/K3472
and for A3 I want JONES, Kayla hyperlink to www.test.com/reference/7895

I want RUSS, Tim not to be hyperlinked because C4 is blank.

Is this possible?

I am guessing it would have to be VBA as if it's a formula in A2, A3, A4, etc it would be deleted when I type that person's name in.

Any help would be great.

In my actual spreadsheet, The person's name is in column A and the Reference column is in column Q.
The data is in A2:AS200

Thanks in advance!
 
Sort by date Sort by votes
Hi,
By default in Excel, the text color of hyperlinks is "blue" before visiting and "purple" after visiting. This color can be freely changed from the Style menu on the Home tab. Similarly, the visited hyperlinks can be changed from the Style menu. You can also change them using VBA. I've added some lines, so give it a try.

AFAIK, about follow the hyperlinks by Ctrl+Click can be done on Word, but cannot on Excel.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "http://www.test.com/reference/"

    'Conditions for event-driven
    If Target.Count <> 1 Then Exit Sub    'More than 2 cells are changed
    If Target.Row < 3 Or Target.Row > 200 Then Exit Sub
    If Target.Column <> 17 Then Exit Sub    'Column Q

    On Error GoTo ErrLine

    'Added
    With ActiveWorkbook.Styles("Followed Hyperlink").Font
        .Color = RGB(0, 0, 0)
    End With

    'Add a Hyperlink
    Application.EnableEvents = False    'Disable event
    If Target.Value <> "" Then    ' If Reference column is NOT blank
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                   sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        'Set hyperlink text
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal" 'Added
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Underline = xlUnderlineStyleNone
        End With
    Else
        Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
    End If
ErrLine:        'Just in case, enable event
    Application.EnableEvents = True
End Sub
 
Upvote 0

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Colo said:
Hi,
By default in Excel, the text color of hyperlinks is "blue" before visiting and "purple" after visiting. This color can be freely changed from the Style menu on the Home tab. Similarly, the visited hyperlinks can be changed from the Style menu. You can also change them using VBA. I've added some lines, so give it a try.

AFAIK, about follow the hyperlinks by Ctrl+Click can be done on Word, but cannot on Excel.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "http://www.test.com/reference/"

    'Conditions for event-driven
    If Target.Count <> 1 Then Exit Sub    'More than 2 cells are changed
    If Target.Row < 3 Or Target.Row > 200 Then Exit Sub
    If Target.Column <> 17 Then Exit Sub    'Column Q

    On Error GoTo ErrLine

    'Added
    With ActiveWorkbook.Styles("Followed Hyperlink").Font
        .Color = RGB(0, 0, 0)
    End With

    'Add a Hyperlink
    Application.EnableEvents = False    'Disable event
    If Target.Value <> "" Then    ' If Reference column is NOT blank
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                   sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        'Set hyperlink text
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal" 'Added
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Underline = xlUnderlineStyleNone
        End With
    Else
        Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
    End If
ErrLine:        'Just in case, enable event
    Application.EnableEvents = True
End Sub
Click to expand...



Thanks for that, I played around with it and made this work(before your reply) - Do you see a better way? I noticed that if I deleted the data in Column Q the text would change in Column A hence why I had to add the extra part:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://test.com/ui/cases/"

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
            'Set hyperlink text
            With Cells(Target.Row, "A").Font
                .Name = "Calibri"
                .Size = 12
                .Bold = True
                .Color = vbBlack
                .Underline = xlUnderlineStyleNone
            End With
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
            With Cells(Target.Row, "A").Font
                .Name = "Calibri"
                .Size = 12
                .Bold = True
                .Color = vbBlack
                .Underline = xlUnderlineStyleNone
            End With
        End If
    End If

    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AS"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

    ' Ignore Errors with Worksheet Clicks
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

ErrLine:        'Just in case, enable event
    Application.EnableEvents = True

End Sub
 
Upvote 0
eli_m said:
Do you see a better way?
Click to expand...
You had the same settings around the font when it sets up the hyperlink and when it removes, so I combined the duplicate portions of code into one.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://test.com/ui/cases/"

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        'Added
        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"    'Added
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If

    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AS"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

    ' Ignore Errors with Worksheet Clicks
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

ErrLine:        'Just in case, enable event
    Application.EnableEvents = True

End Sub
 
Upvote 0
Solution
Colo said:
You had the same settings around the font when it sets up the hyperlink and when it removes, so I combined the duplicate portions of code into one.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://test.com/ui/cases/"

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        'Added
        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"    'Added
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If

    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AS"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

    ' Ignore Errors with Worksheet Clicks
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

ErrLine:        'Just in case, enable event
    Application.EnableEvents = True

End Sub
Click to expand...

Hi, This has been working amazingly! So thank you so much. Is there any way to add to this code and have:
Column 'AH' hyperlink with this address:
mydhl.express.dhl/au/en/tracking.html#/results?id=COLUMN'AH'NUMBERHERE
Eg:
In column AH3 there is a number 492981
I want IF there is a number there for AH3 to hyperlink to:
mydhl.express.dhl/au/en/tracking.html#/results?id=492981

If AH3 is 'N/A' or 'TBC' a formula it does not hyperlink.

Thanks in advance :)
 
Upvote 0
eli_m said:
Hi, This has been working amazingly! So thank you so much. Is there any way to add to this code and have:
Column 'AH' hyperlink with this address:
mydhl.express.dhl/au/en/tracking.html#/results?id=COLUMN'AH'NUMBERHERE
Eg:
In column AH3 there is a number 492981
I want IF there is a number there for AH3 to hyperlink to:
mydhl.express.dhl/au/en/tracking.html#/results?id=492981

If AH3 is 'N/A' or 'TBC' a formula it does not hyperlink.

Thanks in advance :)
Click to expand...

Hi @Colo are you able to help me out with this request?

Thanks so much
 
Upvote 0
Hi @Colo - sorry to bother you again. I tried to play around with the code but only Column A hyperlinks from Column Q but Column AH isn't hyperlinking with data from AH - are you able to shed some light? :


VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sURI As String
sURI = "https://test.com/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With

        If Target.Value <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete
        End If
 
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If
    
    
        sURI = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("AH3:AH200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        'Added
        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AH"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "AH").Value
        Else
            Cells(Target.Row, "AH").Hyperlinks.Delete    'Delete Hyperlink when AH is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "AH").Font
            .Parent.Style = "Normal"    'Added
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If
    
    

    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AS"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

    ' Ignore Errors with Worksheet Clicks
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

ErrLine:        'Just in case, enable event
    Application.EnableEvents = True

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Hyperlink with VBA using column as reference.
Replies
2
Views
374
eli_m
E
E
  • Solved
Hyperlinks using text from another cell
Replies
5
Views
393
Momentman
Momentman
C
  • Question
Using a common value, display unique values that relate/correspond to it
Replies
8
Views
232
chive90
C
S
  • Solved
VBA to copy block of cells - keeping correct cell reference
Replies
5
Views
273
Joe4
Joe4
T
  • Solved
Making the contents of the active cell the search term, and search using that term, copy paste row, next
Replies
2
Views
177
Travis Kunnen
T

Forum statistics

Threads
1,214,932
Messages
6,122,332
Members
449,077
Latest member
jmsotelo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top