Use cell values to create hyperlinks using VBA Worksheet_Change Event

CowFarmer · Aug 17th 2022

I have code that takes the value of a cells in a single column and then uses that value to create a hyperlink within that same cell. It works with the code below. However I'm at a loss to do the same thing with two different columns on the same worksheet. The code below converts the value in column A into a hyperlink. I want to do the same to column C on the same worksheet but with a different hyperlink. I've tried unsuccessfully by adding a new section of code with a new range for column C. I also attempted to add both columns in the code below with additional variables. I haven't done much VBA coding. Any assistance would be much appreciated.

Code

Private Sub Worksheet_Change(ByVal Target As Range)

Dim sPart As String
Dim rMyTarget As Range, c As Range
maxrow = Range ("A" & Rows.Count).End(xlUp).Row
Const sPath = "http://myurl.default.asp?PopUp" 

Set rMyTarget = Intersect(Target, Range("A2:A" & maxrow))
If rMyTarget Is Nothing Then Exit Sub
For Each c In rMyTarget
    On Error GoTo CleanUp
    Application.EnableEvents = False
    sPart = c.Text
    If sPart = "" Then
        '---delete existing hyperlink if any
        If c.Hyperlinks.Count > 0 Then c.Hyperlinks(1).Delete
    Else
        Me.Hyperlinks.Add _
            Anchor:=c, Address:=sPath & c.Text, _
            TextToDisplay:=c.Text
    End If
Next c
CleanUp:
    Application.EnableEvents = True
End Sub

Display More

CowFarmer · Aug 18th 2022

Ok, I think I may have figured it out for the most part. The links are immediately available in column A, however the column C links require clicking in the cell then off the cell to activate the link. What am I missing?

Code

Private Sub Worksheet_Change(ByVal Target As Range)

Dim cPart As String
Dim pPart As String
Dim cMyTarget As Range, c As Range
Dim pMyTarget As Range, p As Range
maxrow1 = Range ("A" & Rows.Count).End(xlUp).Row
maxrow2 = Range ("C" & Rows.Count).End(xlUp).Row
Const cPath = "http://myurl.default.asp?PopUp1" 
Const pPath = "http://myurl.default.asp?PopUp2" 

Set cMyTarget = Intersect(Target, Range("A2:A" & maxrow1))
Set pMyTarget = Intersect(Target, Range("C2:C" & maxrow2))

If Not cMyTarget Is Nothing Then 
    For Each c In cMyTarget
        On Error GoTo CleanUp
        Application.EnableEvents = False
        cPart = c.Text
        If cPart = "" Then
            '---delete existing hyperlink if any
            If c.Hyperlinks.Count > 0 Then c.Hyperlinks(1).Delete
        Else
            Me.Hyperlinks.Add _
                Anchor:=c, Address:=cPath & c.Text, _
                TextToDisplay:=c.Text
        End If
    Next c
Application.EnableEvents = True

ElseIf Not pMyTarget Is Nothing Then 
    For Each p In pMyTarget
        On Error GoTo CleanUp
        Application.EnableEvents = False
        pPart = p.Text
        If pPart = "" Then
            '---delete existing hyperlink if any
            If p.Hyperlinks.Count > 0 Then p.Hyperlinks(1).Delete
        Else
            Me.Hyperlinks.Add _
                Anchor:=p, Address:=pPath & p.Text, _
                TextToDisplay:=p.Text
        End If
    Next p
End If
CleanUp:
    Application.EnableEvents = True
End Sub

Display More

Justin Doward · Aug 19th 2022

Hi CO,

Not sure if this does what you are after, the first only works on the target, the second works through the range depending which range changed.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
Const aPath = "http://myurl.default.asp?PopUp1"
Const cPath = "http://myurl.default.asp?PopUp2"
Dim str As String
str = Target.Value2
Select Case Target.Column
Case 1
Target.Hyperlinks.Add _
anchor:=Target, Address:=aPath & str, _
TextToDisplay:=str
Case 3
Target.Hyperlinks.Add _
anchor:=Target, Address:=cPath & str, _
TextToDisplay:=str
End Select
End If
Exit_Sub:
End Sub

Display More

OR

Code

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
Const aPath = "http://myurl.default.asp?PopUp1"
Const cPath = "http://myurl.default.asp?PopUp2"
Dim str As String
Dim rng As Range, x As Range
Set rng = Target.CurrentRegion
For Each x In rng
str = x.Value2
Select Case Target.Column
Case 1
x.Hyperlinks.Add _
anchor:=x, Address:=aPath & str, _
TextToDisplay:=str
Case 3
x.Hyperlinks.Add _
anchor:=x, Address:=cPath & str, _
TextToDisplay:=str
End Select
Next x
End If
Exit_Sub:
End Sub

Display More

HTH

Justin

CowFarmer · Aug 19th 2022

JD,

Thanks for the help! I've tried both of your code examples. The first is giving me a Type Mismatch on line 6: str = Target.Value2.

The second version works, however it loops through my entire worksheet column by column and applies link apath and cpath to every column (i.e. aPath applied to column 1,3,5,7 etc. and cPath to 2.4.6.8 etc).

I only need to apply links to columns A and C. Also, my code example range starts a row 2 due to headers.

Justin Doward · Aug 20th 2022

Hi CO,

Not sure why the first does not work for you, it works fine here.

The second I should have foreseen, sorry about that. I have rewritten to be more specific. If this one needs to be tailored further please upload an example of your data format. Really it is just about defining the range more precisely.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value2 = vbNullString Then GoTo Exit_Sub
If Not Intersect(Target, Range("A:A, C:C")) Is Nothing Then
Const aPath = "http://myurl.default.asp?PopUp1"
Const cPath = "http://myurl.default.asp?PopUp2"
Dim str As String
Dim i As Long, j As Long
Dim rng As Range, x As Range
i = Target.CurrentRegion.Cells(1, 1).Row
j = Target.CurrentRegion.Rows.Count + i - 1
Set rng = Range(Cells(i, Target.Column), Cells(j, Target.Column))
For Each x In rng
str = x.Value2
Select Case Target.Column
Case 1
x.Hyperlinks.Add _
anchor:=x, Address:=aPath & str, _
TextToDisplay:=str
Case 3
x.Hyperlinks.Add _
anchor:=x, Address:=cPath & str, _
TextToDisplay:=str
End Select
Next x
End If
Exit_Sub:
End Sub

Display More

CowFarmer · Aug 22nd 2022

JD,

Thanks for your help!

I've attached an example spreadsheet. I've set it up similarly to how I have my actual document. The sheet I wish to apply the code to is the result of a query (in this case Sheet3).

Your code above works on a standard table but results in a type mismatch error when refreshing the table constructed from a query on line 2: "If Target.Value2 = vbNullString Then GoTo Exit_Sub".

Also, I'm trying to avoid applying the link to the first row since that's the header row. I tried starting the range at A2 and C2 but it also resulted in errors.

Justin Doward · Aug 24th 2022

Hi CO,

I cannot really help with the line 2 error without being able to replicate it, I do not know what would give an error when checking .value2, you could delete the line and test for blanks using the str = x.value2 then as below use if x = vbnullstring then goto Nxt_X... but it may give the same error.

To start on row 2 just enter a goto into the loop:

Code

For Each x In rng
If x.Row = 1 Then GoTo Nxt_X
code here...
Nxt_X:
Next x

Use cell values to create hyperlinks using VBA Worksheet_Change Event

CowFarmer Aug 17th 2022

Participate now!

Share

Similar Threads

Ignore zero values in range for user defined function

Use a Command Button to Create a Worksheet from a Filter Data

Use VBA to Copy & Paste Unique Value from One Worksheet to Another (Paste as Values)

VBA Loop to create Excel Sheet, save excel sheet to specific folder on computer and generate Outlook 365 Email with attached excel sheet.

Savings Deposit Entry User Form

Help needed to extract multiple entries from cell into generated email using VBA

Users Viewing This Thread