VBA to link cell to website regardless of cell content.

[MJ72]

Hello all!
I am setting up a data base for my coworkers and one column is a client phone number column.
I would like to create a vba that will link the cells in that column to a specific website that won't change even when my coworkers enter and/or change the phone numbers in the cells of that column.

I have been successful, just linking the column cells to the website (that part is an easy right click, as you know) but as soon as the phone number is deleted, changed or a new one is added, it overrides the link and clicking the cell then goes nowhere. How do I "lock" that website to the cells in that column so that regardless of the cell content, clicking on the cell always goes to the website?

Thanks

MJ

 

[Candyman8019]

You can try something like this. Whatever the user enters into the cell, it will be reformatted to a hyperlink that points to a website you specify.

Private Sub worksheet_change(ByVal target As Range)
Dim temp As String

If target.CountLarge > 1 Then Exit Sub

'Create Hyperlink to website for any value entered in column C
If Not Intersect(target, Range("C2:C1000")) Is Nothing Then
temp = target.Value
Application.EnableEvents = False
  target.Formula = "=Hyperlink(""https://www.google.com"",""" & temp & """)"
Application.EnableEvents = True
End If

End Sub

 

[MJ72]

You can try something like this. Whatever the user enters into the cell, it will be reformatted to a hyperlink that points to a website you specify.

Private Sub worksheet_change(ByVal target As Range)
Dim temp As String

If target.CountLarge > 1 Then Exit Sub

'Create Hyperlink to website for any value entered in column C
If Not Intersect(target, Range("C2:C1000")) Is Nothing Then
temp = target.Value
Application.EnableEvents = False
  target.Formula = "=Hyperlink(""https://www.google.com"",""" & temp & """)"
Application.EnableEvents = True
End If

End Sub

Hey Candyman!
Very close!!! Thank you. The only issue now is that when something is entered in any cell of that column, it copies that entry to every other cell. Suggestions?

 

[Candyman8019]

There must be some other formulas in that column that is copying that cell…or some pre-existing VBA code. The snippet it provided above will only update the ‘target’ ie the cell that was changed.

 

[MJ72]

There must be some other formulas in that column that is copying that cell…or some pre-existing VBA code. The snippet it provided above will only update the ‘target’ ie the cell that was changed.

You are correct, I have a vba that copies the phone number in the cell when it is clicked on. It's to allow my coworkers to paste it into the website once opened.
What should I do to correct?

 

[MJ72]

There must be some other formulas in that column that is copying that cell…or some pre-existing VBA code. The snippet it provided above will only update the ‘target’ ie the cell that was changed.

Here's what we've got so far:

Sub Worksheet_SelectionChange(ByVal target As Range) 'single click version

If Intersect(target, Range("L2:L1048576")) Is Nothing Then Exit Sub
ActiveCell.Copy

End Sub

Private Sub worksheet_change(ByVal target As Range)
Dim temp As String

If target.CountLarge > 1 Then Exit Sub

'Create Hyperlink to website for any value entered in column C
If Not Intersect(target, Range("L2:L1048576")) Is Nothing Then
temp = target.Value
Application.EnableEvents = False
target.Formula = "=Hyperlink(""https:website..."",""" & temp & """)"
Application.EnableEvents = True
End If

 

[Candyman8019]

Give this a try...

Sub Worksheet_SelectionChange(ByVal target As Range) 'single click version
Dim dataObj as msForms.DataObject
Dim strLink as string

If Intersect(target, Range("L2:L1048576")) Is Nothing Then Exit Sub
  Set DataObj = New MsForms.DataObject
   strLink = target.value
   DataObj.SetText strLink
   DataObj.PutInClipboard

End Sub

Private Sub worksheet_change(ByVal target As Range)
Dim temp As String

If target.CountLarge > 1 Then Exit Sub

'Create Hyperlink to website for any value entered in column L.
If Not Intersect(target, Range("L2:L1048576")) Is Nothing Then
temp = target.Value
Application.EnableEvents = False
target.Formula = "=Hyperlink(""https:website..."",""" & temp & """)"
Application.EnableEvents = True
End If
end sub

To use the msforms.dataobject you need to have Microsoft Forms 2.0 Object Library referenced in your project.

 

[MJ72]

Unfortunately, the office does not appear to have Microsoft Forms 2.0 as I received an error message immediately when I pasted your code into the vba editor.

Is there possibly another work around?
When I had the "ActiveCell.Copy" code in, and formatted the cell with a hyperlink ,it did copy the contents of the cell for me to paste into the necessary search engine on the target website. My only issue is that as soon as the phone # in the cell was changed or deleted, the hyperlink to the website was obviously deleted as well.

 

[Candyman8019]

You have to enable the reference in your vba project as follows:

 

[MJ72]

Give this a try...

Sub Worksheet_SelectionChange(ByVal target As Range) 'single click version
Dim dataObj as msForms.DataObject
Dim strLink as string

If Intersect(target, Range("L2:L1048576")) Is Nothing Then Exit Sub
  Set DataObj = New MsForms.DataObject
   strLink = target.value
   DataObj.SetText strLink
   DataObj.PutInClipboard

End Sub

Private Sub worksheet_change(ByVal target As Range)
Dim temp As String

If target.CountLarge > 1 Then Exit Sub

'Create Hyperlink to website for any value entered in column L.
If Not Intersect(target, Range("L2:L1048576")) Is Nothing Then
temp = target.Value
Application.EnableEvents = False
target.Formula = "=Hyperlink(""https:website..."",""" & temp & """)"
Application.EnableEvents = True
End If
end sub

To use the msforms.dataobject you need to have Microsoft Forms 2.0 Object Library referenced in your project