VBA: Convert Cell Contents into Hyperlink on Cell Change

[zero269]

Hello,

I'm looking for a way to take the contents of a cell and convert it to a custom hyperlink when a cell change is detected. I'm currently using a drop-down list in one column, and another to build the custom URL using that drop-down list selection.

Here's what I'm using currently to only build the hyperlink if the cell is not blank, AND beginss with a lowercase letter.

=IF(ISBLANK([@[Digital Library]]),"",
IF(AND(CODE(LEFT([@[Digital Library]],1))>96,CODE(LEFT([@[Digital Library]],1))<123),
HYPERLINK(TEXTJOIN("",TRUE,"https://",[@[Digital Library]],".overdrive.com"),[@[Digital Library]]),""))

For example, the above formula will produce the following URL if the cell value is "lapl"

https://lapl.overdrive.com

I was looking at the following post, but I'm not sure how to change it to achieve the same results my formula is doing.

Convert text to hyperlinks with VBA

Hi there, I've looked around all over and cannot find the answer anywhere easily: I have thousands of text URL's that im trying to convert to clickable links in column B of my sheet (excel 2010). Now I know you can do this with a drag down of a formula =hyperlink ect , but I am trying to make...

www.mrexcel.com

I thought I could recycle an "Evaluate" code that I'm using elsewhere, but it's not liking it:

SetURL = Evaluate("FORMULA HERE")

I have another sheet where I'm using a Worksheet Change solution and suspect I'll reuse that and just change the part where action is taken on the cell changes to generate the hyperlink.

Private Sub Worksheet_Change(ByVal Target As Range)

'Set Change Scope to Table Column B only
If Intersect(Target, Range("B" & Rows.Count).End(xlUp)) Is Nothing Then Exit Sub

Dim Changed As Range, c As Range
Dim Scheme As String, Subdomain As String, Domain As String

Scheme = "https://"
Domain = ".overdrive.com"

Set Changed = Intersect(Target, Range("B" & Rows.Count).End(xlUp))
   If Not Changed Is Nothing Then
   Application.EnableEvents = False

   For Each c In Changed
      Subdomain = ActiveCell.Value
   If <cell is not blank> Then <create url/hyperlink>
      Next c

   Application.EnableEvents = True
   End If

End Sub

Any advice would be greatly appreciated…

 

[Domenic]

Try the following...

    For Each c In Changed
        Subdomain = c.Value
        If Len(Subdomain) > 0 Then c.Hyperlinks.Add c, Scheme & c.Value & Domain, , , c.Value
    Next c

Although, I would suggest the following instead...

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Cells.CountLarge > 1 Then Exit Sub 'if more than one cell is changed, exit sub
    
    If Target.Row > 1 Then 'if changed cell is located beyond the first row
        If Target.Column = 2 Then 'if changed cell is located in Column B
        
            Application.EnableEvents = False
            
            Dim Scheme As String
            Scheme = "https://"
            
            Dim Domain As String
            Domain = ".overdrive.com"
            
            Dim Subdomain As String
            Subdomain = Target.Value
            
            If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, Scheme & Target.Value & Domain, , , Target.Value
            
            Application.EnableEvents = True
            
        End If
    End If

End Sub

Hope this helps!

 

[zero269]

Although, I would suggest the following instead...

Hello Domenic,

Thank you for helping me with this. I went with your 2nd suggestion and ran a quick test.

I was able to add in some validation and expand the behavior against two columns. However, I was wondering if is possible to set the range for a Table column instead of the entire column? I use ActiveSheet.ListObjects(1).ListColumns("Overdrive").DataBodyRange in some other places, but haven't been able to figure it out as a replacement for

If Target.Column = 2 Then

In this case, I'm using two columns:

ActiveSheet.ListObjects(1).ListColumns("Overdrive").DataBodyRange
ActiveSheet.ListObjects(1).ListColumns("cloudLibrary").DataBodyRange

The Sheet this particular Table sits on has some data both above and below the Table as it relates to notes, and reference information. Right now I'm just using a test Sheet. I want to avoid any unwanted changes to column headings, Total Row data changes and other information in the same column and outside the Table. This will also accommodate any Table Column arrangements I may make in the future as data gets moved around.

My formula currently only checks to see if the first character is a lowercase letter or not. I found a suitable VBA replacement that works for me considering the data will either be all lowercase (lacountylibrary) , or Proper case (GlendaleLAC) for example.

If Subdomain = LCase(Subdomain) Then 'Test if lowercase

Here's what I've got so far that works across two different columns, recycling some code:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Scheme As String, Subdomain As String
    Scheme = "https://ebook.yourcloudlibrary.com/library/"

    If Target.Cells.CountLarge > 1 Then Exit Sub 'if more than one cell is changed, exit sub
  
    If Target.row > 1 Then 'If changes below first row
      
        'Digital Library Column
        If Target.Column = 2 Then 'if Column B changes
            Application.EnableEvents = False
            Subdomain = Target.Value
          
            'Validate Selection
            If Subdomain = LCase(Subdomain) Then 'Test if lowercase
                If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, "https://" & Target.Value & ".overdrive.com", , , Target.Value
            Else
                If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, Scheme & Target.Value, , , Target.Value
            End If 'Validate Selection
            Application.EnableEvents = True
        End If 'If Column B changes
      
        'clouLibrary Column
        If Target.Column = 4 Then 'if Column D changes
            Application.EnableEvents = False
            Subdomain = Target.Value
          
            'Validate Selection
            If Subdomain = LCase(Subdomain) Then
                If Len(Subdomain) > 0 Then MsgBox Subdomain & " is not a valid cloudLibrary selection."
                ActiveCell.ClearContents
            Else
                If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, Scheme & Target.Value, , , Target.Value
            End If 'Validate Selection
            Application.EnableEvents = True
        End If 'If Column D changes
  
    End If 'If changes below first row

End Sub

Thanks again for any additional help you can provide.

 

[zero269]

UPDATE:
I was able to change the ranges from using the entire column(s) to just the Table Column ranges (ListObject) using the Column Header names using this post here:

Table (ListObject Object) Change Event

Hi, Using Excel 365. Is there such a thing as Table (ListObject Object) Change Event or something better than Worksheet Change Event? I have a Table on a worksheet. A user can enter a new item which triggers the code to sort the table and remove any duplicates. However, I need to add a second...

www.mrexcel.com

Changed... FROM:

If Target.Column = 2 Then 'if Column B changes
If Target.Column = 4 Then 'if Column D changes

TO...

If Not Intersect(Target, ActiveSheet.ListObjects(1).ListColumns("Digital Library").Range) Is Nothing Then 'if Digital Library column changes
If Not Intersect(Target, ActiveSheet.ListObjects(1).ListColumns("cloudLibrary").Range) Is Nothing Then 'if cloudLibrary column changes

This allowed me to still add data above and below the table, as well as move the columns within the table without breaking the code.

However, I'm still looking for a way to solve the following issues:

• Entering an invalid value in the cloudLibrary column, hitting the Enter key, and it clearing the contents of the cell below the changed cell.
• Adding new table rows when pasting multiple values directly below the table that automatically expands the table.... but doesn't run the code on those new cells for the given columns.

I think I'll consider this thread resolved, and post a new question for the others...

Thanks again for your help with getting this far. So far, it's working great!

Updated working code:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.CountLarge > 1 Then Exit Sub
    
    Application.EnableEvents = False
    Dim Scheme As String, Subdomain As String
    Scheme = "https://ebook.yourcloudlibrary.com/library/"

    If Not Intersect(Target, ActiveSheet.ListObjects(1).ListColumns("Digital Library").Range) Is Nothing Then 'if Digital Library column changes
        Subdomain = Target.Value
        
        'Validate Selection
        If Subdomain = LCase(Subdomain) Then 'Test if lowercase
            If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, "https://" & Target.Value & ".overdrive.com", , , Target.Value
        Else
            If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, Scheme & Target.Value, , , Target.Value
        End If 'Validate Selection
        
    End If 'Digital Library

    If Not Intersect(Target, ActiveSheet.ListObjects(1).ListColumns("cloudLibrary").Range) Is Nothing Then 'if cloudLibrary column changes
        Subdomain = Target.Value
        
        'Validate Selection
        If Subdomain = LCase(Subdomain) Then
            If Len(Subdomain) > 0 Then MsgBox Subdomain & " is not a valid cloudLibrary selection."
            ActiveCell.ClearContents
        Else
            If Len(Subdomain) > 0 Then Target.Hyperlinks.Add Target, Scheme & Target.Value, , , Target.Value
        End If 'Validate Selection
        
    End If 'cloudLibrary
    
    Application.EnableEvents = True

End Sub

 

[zero269]

Entering an invalid value in the cloudLibrary column, hitting the Enter key, and it clearing the contents of the cell below the changed cell.

OK , so it looks like I was able to temporarily address this issue by squeezing in the 2nd line below to offset the row by -1:

If Len(Subdomain) > 0 Then MsgBox Subdomain & " is not a valid cloudLibrary selection."
ActiveCell.Offset(-1, 0).Activate 'if invalid entry, go up 1 row
ActiveCell.ClearContents

I still need to figure out a better way though, because this will be an issue if I copy/paste the value where the Enter key is not used...

 

[zero269]

I still need to figure out a better way though, because this will be an issue if I copy/paste the value where the Enter key is not used...

This works for both entry methods.
It first checks if the active cell contains the entered value (Subdomain) and will go up one row if it doesn't match, then clear the contents.
If it matches, it will not offset and just clear the contents...

If Len(Subdomain) > 0 Then MsgBox Subdomain & " is not a valid cloudLibrary selection."
     If ActiveCell.Value <> Subdomain Then ActiveCell.Offset(-1, 0).Activate
ActiveCell.ClearContents

Note: my variable Subdomain = Target.Value