Make cells to hyperlinks

M

Mikedk64

New Member
Joined
Jun 16, 2017
Messages
34
Office Version
  1. 365
Platform
  1. Windows
Hi you all,

I have a userform, with this code.
Is it possible to make a code, so every time Label1 is inserted in the worksheet, it will work as a hyperlink?
Now is it just a "dead" cell.

Code: 
Private Function MakeCursorFromBytes() As String
    #If VBA7 Then
        Const ByteFactor = 24
    #Else
        Const ByteFactor = 16
    #End If


    Dim lPos As Long
    Dim arCurBytes1() As Variant
    Dim arCurBytes2() As Variant


    arCurBytes1 = Array(0, 0, 2, 0, 1, 0, 32, 32, 16, 0, 12, 0, 1, 0, 232, 2, _
        0, 0, 22, 0, 0, 0, 40, 0, 0, 0, 32, 0, 0, 0, 64, 0, _
        0, 0, 1, 0, 4, 0, 0, 0, 0, 0, 128, 2, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 128, 0, 0, 128, 0, 0, 0, 128, 128, 0, 128, 0, _
        0, 0, 128, 0, 128, 0, 128, 128, 0, 0, 128, 128, 128, 0, 192, 192, _
        192, 0, 0, 0, 255, 0, 0, 255, 0, 0, 0, 255, 255, 0, 255, 0, _
        0, 0, 255, 0, 255, 0, 255, 255, 0, 0, 255, 255, 255, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 15, 255, 255, 248, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 255, 255, 255, 255, 128, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 15, 255, 255, 255, 255, 128, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 255, 255, 255, 255, 255, 248, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 255, 255, 255, 255, 255, 248, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 15, 255, 255, 255, 255, 255, 248, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 15, 255, 255, 255, 255, 255, 255, 128, 0, 0, 0, 0, 0, 0)


    arCurBytes2 = Array(0, 0, 255, 255, 255, 255, 255, 255, 255, 128, 0, 0, 0, 0, 0, 0, _
        0, 0, 255, 136, 255, 255, 255, 255, 255, 128, 0, 0, 0, 0, 0, 0, _
        0, 15, 248, 0, 255, 255, 255, 255, 255, 128, 0, 0, 0, 0, 0, 0, _
        0, 15, 128, 0, 255, 255, 255, 255, 127, 128, 0, 0, 0, 0, 0, 0, _
        0, 248, 0, 0, 255, 127, 247, 248, 15, 128, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 15, 128, 248, 15, 128, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 15, 128, 248, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 15, 128, 248, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 15, 128, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 248, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255, 255, _
        255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, _
        255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 248, _
        7, 255, 255, 240, 7, 255, 255, 224, 3, 255, 255, 192, 3, 255, 255, 128, _
        1, 255, 255, 128, 1, 255, 255, 0, 1, 255, 255, 0, 0, 255, 254, 0, _
        0, 255, 254, 0, 0, 255, 252, 0, 0, 255, 252, 32, 0, 255, 248, 96, _
        0, 255, 252, 224, 0, 255, 255, 224, 1, 255, 255, 224, 7, 255, 255, 224, _
        15, 255, 255, 224, 127, 255, 255, 225, 255, 255, 255, 225, 255, 255, 255, 225, _
        255, 255, 255, 225, 255, 255, 255, 243, 255, 255, 255, 255, 255, 255, 255, 255)


    MakeCursorFromBytes = SaveCurToDisk(ByVal arCurBytes1)


End Function
Private Function SaveCurToDisk(ByVal Ar As Variant) As String
 
    Dim i As Long
    Dim FileNum As Long
    Dim Bytes() As Byte
 
    ReDim Bytes(LBound(Ar) To UBound(Ar))
 
    For i = LBound(Ar) To UBound(Ar)
        Bytes(i) = CByte((Ar(i)))
    Next
 
    FileNum = FreeFile
    Open Environ("Temp") & "\temp.cur" For Binary As #FileNum
        Put #FileNum, 1, Bytes
    Close FileNum
    
    SaveCurToDisk = Environ("Temp") & "\temp.cur"
 
End Function


Private Sub Label1_Click()
    If Len(Label1.Caption) <> 0 Then
        Shell "explorer.exe" & " " & Label1.Caption, vbNormalFocus
    End If
    End Sub


Private Sub boAdd_Click()
Dim erow As Long
arow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(arow, 1).Value = CbName.Value
Cells(arow, 2).Value = Val(TextBoxAge.Text)
Cells(arow, 3).Value = TextBoxGender.Text
Cells(arow, 4).Value = cbInterest.Value
Cells(arow, 5).Value = Label1.Caption




Brow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(Brow, 4).Value = cbInterest2.Value
If cbInterest2.Value <> "" Then
    Cells(Brow + 0, 1).Value = CbName.Value
    Cells(Brow + 0, 2).Value = Val(TextBoxAge.Text)
    Cells(Brow + 0, 3).Value = TextBoxGender.Text
    Cells(Brow + 0, 5).Value = Label1.Caption
End If


Crow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(Crow, 4).Value = cbInterest3.Value
If cbInterest3.Value <> "" Then
    Cells(Crow + 0, 1).Value = CbName.Value
    Cells(Crow + 0, 2).Value = Val(TextBoxAge.Text)
    Cells(Crow + 0, 3).Value = TextBoxGender.Text
    Cells(Crow + 0, 5).Value = Label1.Caption
End If


End Sub


Private Sub boSource_Click()
    Dim sPath As String
    
    On Error Resume Next
    With Label1
        .BackStyle = fmBackStyleTransparent
        .Font.Name = "Courier New"
        .Font.Underline = True
        .Font.Bold = True
        .Font.Size = 10
        .WordWrap = False
        .ForeColor = vbBlue
        .ControlTipText = "Click Link to open folder."
        sPath = CreateObject("Shell.Application").BrowseForFolder(0, "Select a Folder...", 0, 0).Self.Path
        If Len(sPath) Then Label1.Caption = sPath
    End With
End Sub


Private Sub UserForm_Initialize()
    Label1.Caption = ""
    Label1.BackStyle = fmBackStyleTransparent
End Sub
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
You're talking about these two lines?

Code: 
1. Cells(Brow + 0, 5).Value = Label1.Caption
2. Cells(Crow + 0, 5).Value = Label1.Caption

You'll likely need to look into the Hyperlinks.Add Method. So, I suppose it'll end up looking something like this:

Code: 
1. ActiveSheet.Hyperlinks.Add Anchor:=Cells(Brow + 0, 5), Address:= "http://www.google.com", TextToDisplay:=Label1.Caption
2. ActiveSheet.Hyperlinks.Add Anchor:=Cells(Crow + 0, 5), Address:= "http://www.google.com", TextToDisplay:=Label1.Caption

Hopefully this helps.
 
Last edited:
Upvote 0
Hi Dushi,

This is kind of what i asking for.
But in my case i don't want to link to a specefic place.
It is difficult to describe, but in my userform i have a button where i can chose a folder i want to link to.
This folder is transferred to "Brow" and "Crow", so the folder is not the same every time, and therefor can i not link to a specific place in the code.
I hope this make sense :)
 
Upvote 0
Doesn't make sense. You said you want to insert a hyperlink...so when you click the cell, where do you want the hyperlink to go to? A folder?

If you're trying to link to a folder, then just replace "http://www.google.com" with the folder path..

Example:

Address:="C:\Windows"
 
Upvote 0
Ok, let me try again :)

I can't figure out how to insert a picture in here, so in this link you can see a picture of my userform :)
Source knap til link til mappe - Dansk Regneark Forum

The purpose of the worksheet is that my colleagues can go into it and put different information's in about them self.
So when they have typed in "name", "age", "gender" and have selected a interest or two they can push the source button and select there personal folder.
I would therefor love that this link "the link to there personal folder" is like a hyperlink in the worksheet

So for each colleague there will be a different folder, and therefor can i not type in a pre-selected folder in the code.
 
Upvote 0
I can't open your link at work unfortunately.

Have you tried the code I gave you?

From your code:
Rich (BB code): 
Label1.Caption = sPath

That tells me that Label1.Caption (and your sPath variable) contains the path you want to use.

So change it to:

Rich (BB code): 
1. ActiveSheet.Hyperlinks.Add Anchor:=Cells(Brow + 0, 5), Address:=sPath, TextToDisplay:="DisplayText"
2. ActiveSheet.Hyperlinks.Add Anchor:=Cells(Crow + 0, 5), Address:=sPath, TextToDisplay:="DisplayText"

Or you can substitute "sPath" with "Label1.Caption" (without the quotes).

To clarify, these two lines would (should) replace the following lines:

Rich (BB code): 
1. Cells(Brow + 0, 5).Value = Label1.Caption
2. Cells(Crow + 0, 5).Value = Label1.Caption
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Search a range for a specific color of rows, relocate those cells to another sheet, return previous sheet formatting to blank and sort secondary sheet
Replies
4
Views
378
Royalbloodi
R
E
  • Question Question
VBA - If Cell IsDate and Another Column is a formula then make Cell a hyperlink
2
Replies
10
Views
253
Alex Blakenburg
A
E
  • Locked
  • Question Question
VBA - If Cell IsDate and Another Column is a formula then make Cell a hyperlink
Replies
2
Views
110
Fluff
Fluff
M
  • Question Question
How to Make this Macro work Fast?
Replies
2
Views
501
Georgiboy
Georgiboy
D
  • Question Question
VBA Code to Apply an AVERAGE of a Range on Cells as New Records are added Via a User Form
Replies
2
Views
137
Denny57
D

Forum statistics

Threads
1,225,156
Messages
6,183,227
Members
453,152
Latest member
ChrisMd

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