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

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
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

M
  • Question
How to Make this Macro work Fast?
Replies
2
Views
354
Georgiboy
Georgiboy
D
  • Question
Pasting string - variable in cell - ERROR
Replies
9
Views
282
Alex Blakenburg
A
E
  • Solved
Select data and paste macro problems
Replies
4
Views
385
Zot
Z
J
  • Question
Scraping data from WIFI networks that are available
9 10 11
Replies
109
Views
5K
Prome3
P
E
  • Solved
VBA Find match, if found, copy rows and paste in different workbook
Replies
6
Views
286
MARK858
MARK858

Forum statistics

Threads
1,215,483
Messages
6,125,064
Members
449,206
Latest member
Healthydogs

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