Multiple hyperlinks in a single cell

[GaryA]

Is there any way to put more than one hyperlink in a single cell?

[Bob Phillips]

If you could, how would it know which one to follow?

[GaryA]

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.

[Ken Puls]

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.

[GaryA]

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.

[GaryA]

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

[GaryA]

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.

[Ken Puls]

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:

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?

[GaryA]

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.

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.

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

[Ken Puls]

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,