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!
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Sort by date Sort by votes
Hi,
It can be done using VBA. As the Reference column, column Q is set in the following sample code.

VBA Code: 
Sub Sample1()
    Const sURI As String = "http://www.test.com/reference/"
    Dim i As Long
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "Q").Value <> "" Then ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, "A"), Address:= _
            sURI & Cells(i, "Q").Value, TextToDisplay:=Cells(i, "A").Value
        End If
    Next
    MsgBox "Done"
End Sub
 
Upvote 0
Colo said:
Hi,
It can be done using VBA. As the Reference column, column Q is set in the following sample code.

VBA Code: 
Sub Sample1()
    Const sURI As String = "http://www.test.com/reference/"
    Dim i As Long
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "Q").Value <> "" Then ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, "A"), Address:= _
            sURI & Cells(i, "Q").Value, TextToDisplay:=Cells(i, "A").Value
        End If
    Next
    MsgBox "Done"
End Sub
Click to expand...
Oh wow! I would have never been able to work that out. Am I able to make it not a macro and do it only when Column Q has text?

Thank you for your help!
 
Upvote 0
I tried it as a macro and it worked. All I need to do is make it only run the macro when Column Q has text inserted. Is that possible to do with Worksheet_SelectionChange?

If so how can I merge it with what I already have:
VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate
End If
End Sub

and is it possible to have the hyperlink text:
Calibri, Bold and Font Size: 12 with no underline?

and only work for A3:A200?
 
Upvote 0
Hi eli_m,

I believe that better have it as Worksheet_Change instead of Worksheet_SelectionChange event so that every time a value in column Q is updated, a Hyperlink on column A is also updated.
After trying the following event, if you still think SelectionChange event is better, please let me know.

To make it work, just place the following code in the same sheet module as Worksheet_SelectionChange.

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
    
    '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
            .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
Colo said:
Hi eli_m,

I believe that better have it as Worksheet_Change instead of Worksheet_SelectionChange event so that every time a value in column Q is updated, a Hyperlink on column A is also updated.
After trying the following event, if you still think SelectionChange event is better, please let me know.

To make it work, just place the following code in the same sheet module as Worksheet_SelectionChange.

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
   
    '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
            .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...
I already have a worksheet_change, how would I merge them?

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

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

End Sub

Thank you again - you're a massive help!
 
Upvote 0
Okay, here's a merged one. Please let me know if those two procedures work without interfering with your actual environment.

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
    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
                .Underline = xlUnderlineStyleNone
            End With
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
        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
Colo said:
Okay, here's a merged one. Please let me know if those two procedures work without interfering with your actual environment.

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
    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
                .Underline = xlUnderlineStyleNone
            End With
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
        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
Click to expand...
 
Upvote 0
This works amazing but the visited link colour is purple instead of black:
1661491874122.png

Will setting the font to black fix it? eg:

VBA Code: 
                .Name = "Calibri"
                .Size = 12
                .Bold = True
                .Color = "Black"

Also right now the link is active when I click it - is there a way to make it so I have to do Ctrl+Click instead? I thought that was the default anyway as I don't want to go to the link everytime I click the name in column A
 
Upvote 0
Colo said:
Okay, here's a merged one. Please let me know if those two procedures work without interfering with your actual environment.

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
    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
                .Underline = xlUnderlineStyleNone
            End With
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete    'Delete Hyperlink when Q is empty
        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
Click to expand...
Hi Colo, any chance you can help me with the post above this? :)
Thanks in advance
 
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
375
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
233
chive90
C
S
  • Solved
VBA to copy block of cells - keeping correct cell reference
Replies
5
Views
277
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
181
Travis Kunnen
T

Forum statistics

Threads
1,214,985
Messages
6,122,606
Members
449,089
Latest member
Motoracer88

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