Multiple hyperlinks in a single cell

GaryA

New member
Joined
Apr 6, 2012
Messages
51
Reaction score
0
Points
0
Is there any way to put more than one hyperlink in a single cell?
 
If you could, how would it know which one to follow?
 
Hi Bob,

Actually, this would be ideal. For example, we have a spreadsheet that itemizes process steps by Row. For that same row, the process step is associated with multiple artifacts or hyperlinks, with the full UNC path to the artifact (the full path tells me which link to follow). For metric purposes, even though we have multiple artifacts, it still counts as 1 process step. This probably could be better served in a database, but I find Excel far easier to manipulate.

I have no idea if this can be done, but it would sure be a nice feature have available.
 
Hi Gary,

I think you're out of luck on this one. I can't think of any way to get mutliple hyperlinks into a single cell.
 
I would like to run this by you and maybe you can offer some guidance on its implementation.

1. Format the target cell for multiple lines (ALT + ENTER)
2. On each line put a different Path to a file, folder or URL.
Note: These cells would always be formatted this way.
3. Create a Macro (SENDKEYS) to select the specific line (1, 2, 3, 4 or 5) in the Active Cell and copy it to the clipboard or an array, convert the contents of the clipboard or array(value) to a hyperlink and navigate the path.
 
Last edited:
Well, I have put multiple paths in a single cell, on separate lines, CHR(10), and can navigate to the individual paths by using Chandoos SplitCell routines and grabbing a target path. See attachment.

However, it is not yet complete. I need to assign keyboard macros to the target paths. For some reason, the Application.OnKey "^1", "Nav_Hyp1" is not working. Any ideas?

Here is the code:

Sub Nav_Hyp1()
On Error Resume Next
Range("MultiLink").Select
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long

splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)

Hyp1 = splitVals(0)
Hyp2 = splitVals(1)
Hyp3 = splitVals(2)
Hyp4 = splitVals(3)
Hyp5 = splitVals(4)

ActiveWorkbook.FollowHyperlink Address:=Hyp1, NewWindow:=True

Application.OnKey "^1", "Nav_Hyp1"

End Sub
 

Attachments

  • MultipleLinksInSingleCell.zip
    32 KB · Views: 603
Done it! Had to add the following code to the "ThisWorkbook" Module. Updated file attached.

Private Sub Workbook_Activate()
Application.OnKey "^1", "Nav_Hyp1"
Application.OnKey "^2", "Nav_Hyp2"
Application.OnKey "^3", "Nav_Hyp3"
Application.OnKey "^4", "Nav_Hyp4"
Application.OnKey "^5", "Nav_Hyp5"
End Sub

Private Sub Workbook_Deactivate()
Application.OnKey "^1", ""
Application.OnKey "^2", ""
Application.OnKey "^3", ""
Application.OnKey "^4", ""
Application.OnKey "^5", ""
End Sub

How would you go about assigning the "Left Mouse button" + "1" combination to lauch a macro? It would give you more of the feel of clicking on an actual hyperlink in the cell.
 

Attachments

  • MultipleLinksInSingleCell2.zip
    32.6 KB · Views: 580
Last edited:
Hi Gary,

Way to go! I'm glad you got that part worked out.

With regards to capturing the "Left Mouse Button" + 1 combination, I'm not sure how realistic that is. The issue is that when you left click that immediately triggers an action. When you press the number one, the same thing. The mouse button is not like the CTRL or ALT keys in that regard that wait for a secondary input.

There are a couple of Worksheet events that you might be able to use though... a double click and a right click event. Their signatures are:
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

End Sub

Alternately, you could pop up a box on doubleclick asking them which of the five links you want to follow. You could have that autopopulate from in a userform. So basically you'd double click the cell, then click on the desired link. Would that work?
 
Hi Ken, I got side tracked with trying to validate the individual links on the separate lines. I modified the check-links code to determine the start and stop characters values for each line, then attempt to change the color of the line depending on the link valiation. Link validation seems to work for all individual lines but it fails to highlight the text start/stop correctly. I removed all the CHR(10)'s during debug thinking that may have something to do with it, but I get the same problem.:confused2:

Nav_Hyp1_Link_Checks Works: It validated the first link and updated the color of line 1 correctly.

Nav_Hyp2_Link_Checks Fails: It validated the second link but does not update the color of the second line based on start/stop correctly.

Code:
Sub Nav_Hyp1_Link_Checks()
     'On Error Resume Next
    Range("MultiLink").Select
    
    'splits Text active cell using ALT+10 char as separator
    Dim splitVals As Variant
    Dim totalVals As Long
    Dim bNoRights As Boolean
    
    splitVals = Split(ActiveCell.Value, Chr(10))
    totalVals = UBound(splitVals)
      
    Hyp1 = splitVals(0)
    Hyp2 = splitVals(1)
    
    'Get Line 1 Range
    Start1 = InStr(Range("MultiLink").Value, Hyp1)
    End1 = InStr(Range("MultiLink").Value, Hyp2) - 2
        
    '***********************************************************************
    ' Hyperlink Validation - Check multilink line in single cell
    '***********************************************************************
    ExistPath = False
    If Left(Hyp1, 7) = "http://" Or Left(Hyp1, 8) = "https://" Or Left(Hyp1, 6) = "ftp://" Or Left(Hyp1, 7) = "ftps://" Then
        ExistPath = InternetCheckConnection(Hyp1, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
    Else
         'Hyp1 = " "" " + Hyp1 + " "" "
        On Error Resume Next
        Err.Clear
        If Len(Dir(Hyp1)) > 0 Then ' verify path
                If Err.Number = 52 Then
                    'Error thrown due to lack of directory access
                    bNoRights = True
                Else
                    ExistPath = True
                End If
        Else
       
           If Len(Dir(Hyp1, vbDirectory)) > 0 Then ' verify the file
                If Err.Number = 52 Then
                    'Error thrown due to lack of directory access
                    bNoRights = True
                Else
                    ExistPath = True
                End If
        End If
        
    End If
        
    If ExistPath Then
            With ActiveCell.Characters(Start1, End1).Font ' Turn line blue if valid
            .Color = RGB(0, 0, 255)
            End With
            Debug.Print "Valid"
            ActiveWorkbook.FollowHyperlink Address:=Hyp1, NewWindow:=True
    Else
        If bNoRights Then
            With ActiveCell.Characters(Start1, End1).Font ' Turn line green if no access to folder
            .Color = RGB(0, 255, 0)
            End With
            Debug.Print "No Permissions"
        Else
            With ActiveCell.Characters(Start1, End1).Font  ' Turn line red if not valid
            .Color = RGB(255, 0, 0)
            End With
            Debug.Print "Not Valid"
        End If
    
    End If
    
Err_Trap:
    If Err <> 0 Then
        Err.Clear
        Resume Next
    End If
    End If
End Sub




Sub Nav_Hyp2_Link_Checks()
'On Error Resume Next
Range("MultiLink").Select

With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With

'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
Dim bNoRights As Boolean

splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)

Hyp2 = splitVals(1)
Hyp3 = splitVals(2)

'Get Line 2 Range
Start2 = InStr(Range("MultiLink").Value, Hyp2)
End2 = InStr(Range("MultiLink").Value, Hyp3) - 2

'***********************************************************************
' Hyperlink Validation - Check multilink line in single cell
'***********************************************************************
ExistPath = False
If Left(Hyp2, 7) = "http://" Or Left(Hyp2, 8) = "https://" Or Left(Hyp2, 6) = "ftp://" Or Left(Hyp2, 7) = "ftps://" Then
ExistPath = InternetCheckConnection(Hyp2, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
If ExistPath = 0 Then
With ActiveCell.Characters(Start2, End2).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Exit Sub
Else
With ActiveCell.Characters(Start2, End2).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
ActiveWorkbook.FollowHyperlink Address:=Hyp2, NewWindow:=True
Exit Sub
End If
Else
On Error Resume Next
Err.Clear
If Len(Dir(Hyp2)) > 0 Then ' verify path
If Err.Number = 52 Then
'Error thrown due to lack of directory access
bNoRights = True
Else
ExistPath = True
End If
Else

If Len(Dir(Hyp2, vbDirectory)) > 0 Then ' verify the file
If Err.Number = 52 Then
'Error thrown due to lack of directory access
bNoRights = True
Else
ExistPath = True
End If
End If

End If

If ExistPath Then
With ActiveCell.Characters(Start2, End2).Font ' Turn line blue if valid
.Color = RGB(0, 0, 255)
End With
Debug.Print "Valid"
ActiveWorkbook.FollowHyperlink Address:=Hyp2, NewWindow:=True
Else
If bNoRights Then
With ActiveCell.Characters(Start2, End2).Font ' Turn line green if no access to folder
.Color = RGB(0, 255, 0)
End With
Debug.Print "No Permissions"
Else
With ActiveCell.Characters(Start2, End2).Font ' Turn line red if not valid
.Color = RGB(255, 0, 0)
End With
Debug.Print "Not Valid"
End If

End If

Err_Trap:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End If
End Sub
 
Last edited:
Hi Gary,

Can you upload a new version of the file? I'm a bit lost in all the changes here. I tried adding the last post's routines to the prior file, but it was misisng something for me.

Thanks,
 
Hi Ken, updated file attached.
 

Attachments

  • MultipleLinksInSingleCell3.zip
    52.3 KB · Views: 75
Hi Gary,

This isn't perfect, you may have to do a little work on the last one, as it is reformatting the first line a bit. But hopefully it will get you close.

Code:
Sub CheckAndColorLinks()
    SetDefaultMultiLinkFont
    
    'splits Text active cell using ALT+10 char as separator
    Dim splitVals As Variant
    Dim lHyp As Long
    Dim sHyp As String
    Dim lStart As Long
    Dim lEnd As Long
    Dim bNoRights As Boolean
    
    splitVals = Split(ActiveCell.Value, Chr(10))
      
    For lHyp = 0 To UBound(splitVals) - 1
        sHyp = splitVals(lHyp)
        
        'Get Line 1 Range
        lStart = InStr(Range("MultiLink").Value, sHyp) ' Get start position of line 1
        lEnd = Len(sHyp) ' Get end position of line 1 by determining start position of line 2, less CHR(10)
        
        '***********************************************************************
        ' Hyperlink Validation - Check multilink line in single cell
        '***********************************************************************
        ExistPath = False
        If Left(sHyp, 7) = "http://" Or Left(sHyp, 8) = "https://" Or Left(sHyp, 6) = "ftp://" Or Left(sHyp, 7) = "ftps://" Then
            ExistPath = InternetCheckConnection(sHyp, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
            If ExistPath = 0 Then
                With ActiveCell.Characters(lStart, lEnd).Font  ' Turn line red if not valid
                    .Color = RGB(255, 0, 0)
                End With
            Else
                With ActiveCell.Characters(lStart, lEnd).Font  ' Turn line blue if valid
                    .Color = RGB(0, 0, 255)
                End With
                ActiveWorkbook.FollowHyperlink Address:=sHyp, NewWindow:=True
            End If
            
        Else
             'Hyp1 = " "" " + Hyp1 + " "" "
            On Error Resume Next
            Err.Clear
            If Len(Dir(sHyp)) > 0 Then ' verify path
                    If Err.Number = 52 Then
                        'Error thrown due to lack of directory access
                        bNoRights = True
                    Else
                        ExistPath = True
                    End If
            Else
           
               If Len(Dir(sHyp, vbDirectory)) > 0 Then ' verify the file
                    If Err.Number = 52 Then
                        'Error thrown due to lack of directory access
                        bNoRights = True
                    Else
                        ExistPath = True
                    End If
               End If
            End If
            
        End If
            
        If ExistPath Then
                With ActiveCell.Characters(lStart, lEnd).Font ' Turn line blue if valid
                .Color = RGB(0, 0, 255)
                End With
                Debug.Print "Valid"
                ActiveWorkbook.FollowHyperlink Address:=sHyp, NewWindow:=True
        Else
            If bNoRights Then
                With ActiveCell.Characters(lStart, lEnd).Font ' Turn line green if no access to folder
                .Color = RGB(0, 255, 0)
                End With
                Debug.Print "No Permissions"
            Else
                With ActiveCell.Characters(lStart, lEnd).Font  ' Turn line red if not valid
                .Color = RGB(255, 0, 0)
                End With
                Debug.Print "Not Valid"
            End If
        
        End If
        
    Next lHyp
    
Err_Trap:
    If Err <> 0 Then
        Err.Clear
        Resume Next
    End If
End Sub

Just so you know, I've changed it so that you don't have to rely on 6 different variables, in fact, it will support as many links as you throw in there.

One more thing... you should REALLY make sure you've got Option Explicit at the top of your modules. It will force you to declare all of your variables, which will save you down the line later on.
 
Outstanding! This is exactly what it should do. I'll try to work out the the formatting issue.

Yes, I agree with you, use of Option Explicit is a must.

Thanks for all your help. :)
 
Updated workbook attached.

1. Added RightMouse click navigation to hyperlink 1 thru 5.

How would you prevent display of the Hyperlink Lines 1 thru 5 (right mouse click)if cell is not a multilink cell?
Is there a better way to do this so as not to be limited to just 5 lines?

2. Now testing for empty lines between links.

3. Adjusting the formula bar to display all the lines when clicking on Multilink Cell.

How would you automatically adjust the formula bar based on the number of lines in ANY cell.

4. Need to apply the CheckAndColorLinks() macro to multiple Multilink cells in a specific column.

How would you quickly identify if a cell is multilink or not via vba?
 

Attachments

  • MultipleLinksInSingleCell4.zip
    42.1 KB · Views: 72
Last edited:
Additionally. Now using Option Explicit. This seemed to have fixed the color issue with line 1.

Had to add an addional CHR(10) at the end of the Multilink cell to get the last line link color to work correctly. Not sure why?
 
GaryA said:
How would you quickly identify if a cell is multilink or not via vba?
Each of your links has either a : or a \\ character set in it somewhere, doesn't it? (C:\, http://, ftp://, \\servername) So why not do a quick count on those... if anything ends up with more than one, it must be a multilink cell.

GaryA said:
How would you automatically adjust the formula bar based on the number of lines in ANY cell.
So to do this, you'd need to hook it to a worksheet change event. The framework would be something like this:
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.FormulaBarHeight = HowManyLinesIs(Target)
    
End Sub

You'd need to write the "HowManyLinesIs" function for this to make it work though. Something that starts like this:

Function HowManyLinesIs(rngTarget as range) as Long

'Check how many times : and \\ exist in rngTarget.Text

End Function

GaryA said:
How would you prevent display of the Hyperlink Lines 1 thru 5 (right mouse click)if cell is not a multilink cell?
Is there a better way to do this so as not to be limited to just 5 lines?
The actual right click routine can be re-written to use a more dynamic approach like I did with the last one (sorry, I'm out of time for tonight). I'd then link the selection change to create/destroy the menu based on the worksheets_selectionchange event as described above.

Hopefully that helps get you started, but if not I'll circle back with you tomorrow. :)
 
Hi Ken,

Automatically adjusting the FormulaBarHeight:

Function AutoAdjustMultilink(rngTarget As Range) As Long
'Count the total # of "Chr(10)" characters in Active cell and pass value to the Worksheet_SelectionChange Event to automaticaly adjust the FormulaBarHeight
AutoAdjustMultilink = (Len(ActiveCell) - Len(Replace(ActiveCell, Chr(10), ""))) + 1
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.FormulaBarHeight = AutoAdjustMultilink(Target)
End Sub

Counting "//" and ":" in Active Cell:

Function HowManyLinesIs(rngTarget As Range) As Long 'Total count of "//" and ":" in Active Cell
HowManyLinesIs = (Len(ActiveCell) - Len(Replace(ActiveCell, "//", ""))) + (Len(ActiveCell) - Len(Replace(ActiveCell, ":", "")))
End Function

I may need your help to use a more dynamic approach to the Rt mouse click event.

Thanks!
 
Last edited:
Uploaded new file.

Updated SelectionChange event for HowManyLinesIs:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Count the total # of "Chr(10)" characters in Active cell and pass value to the Worksheet_SelectionChange Event to automaticaly adjust the FormulaBarHeight
Application.FormulaBarHeight = AutoAdjustMultilink(Target)

' Is this a Multilink cell or not?
If HowManyLinesIs(Target) > 1 Then
MsgBox "This is a Multilink Cell"
Else
MsgBox "This is not a Multilink Cell"
End If
End Sub
 

Attachments

  • MultipleLinksInSingleCell5.zip
    45 KB · Views: 36
Last edited:
Hi Ken,

Updated file attached:

1. Added MultiLink paths to Right Mouse Click menu.
2. Automatically determines if the active cell contains multilinks.

How would you change the font color of the Right Mouse Click menu based on valid / invalid links?

I am still interested in how you would re-write the right click routine to use a more dynamic approach.
 

Attachments

  • MultipleLinksInSingleCell6.zip
    51.4 KB · Views: 129
Last edited:
GaryA said:
How would you change the font color of the Right Mouse Click menu based on valid / invalid links?
So far as I know we can't change the colour of the text in the Right Click menu. We could probably add an icon there though... maybe a different one for good/bad? I'll have to look in to how to do that again, it's been a while.

GaryA said:
I am still interested in how you would re-write the right click routine to use a more dynamic approach.
Will get back to you on this. My last few and next few days have been ridiculously busy. So much so that I haven't been online at all since Friday. :(
 
Back
Top