在 Excel VBA 问题中打开超链接

Question

I've been trying to find/write a macro that opens all hyperlinks contained in a selected range at once. The code I've come across works on only some types of hyperlinks, specifically hyperlinks added through either the right click/Insert>Link/Ctrl+K. The code wont recognise any hyperlinks that are formed using the HYPERLINK() function.

Here's the code I found online:

Sub OpenMultipleLinks()
    On Error Resume Next
    Set myRange = Application.Selection
    Set myRange = Application.InputBox("Range", "OpenMultipleLinks", myRange.Address, Type:=8)
    For Each oneLink In myRange.Hyperlinks
        oneLink.Follow
    Next
End Sub

And here's the formula of a cell that becomes a hyperlink.

=IF($D2="All Charts","",HYPERLINK("http://SubstituteWebsite/ChartId="&$D2&$AF$1,"link"))

Answer 1

You need to parse/evaluate the "hyperlink" formula first. Assuming all your links are in col A this will do what you want:

    Sub link()
        Dim arr, arr2, j As Long
        arr = Sheet1.Range("A1").CurrentRegion.Formula2 'get all in an array
        For j = 1 To UBound(arr)
            If Left(arr(j, 1), 3) = "=HY" Then 'check if it's a formula
                arr(j, 1) = Evaluate(Split(Mid(arr(j, 1), 2), ",")(0) & ")") 'split the url from the rest, evaluate and replace in array
            End If
            ActiveWorkbook.FollowHyperlink Address:=arr(j, 1), NewWindow:=True 'open in default browser
        Next j
    End Sub

Best of luck,

ceci

Answer 2

Since you do not answer my clarification questions, I will assume that my understanding is correct. So, the following code will work if your formulae containing 'HYPERLINK' formula inside respect the pattern you show us and it should be followed without evaluating if the formula condition is True :

Sub OpenMultipleLinks()
    Dim myrange As Range, cel As Range, oneLink
    On Error Resume Next
     Set myrange = Application.Selection
     Set myrange = Application.InputBox("Range", "OpenMultipleLinks", myrange.Address, Type:=8)
     For Each oneLink In myrange.Hyperlinks
          oneLink.Follow
     Next
    On Error GoTo 0
    For Each cel In myrange
        If InStr(cel.Formula, "HYPERLINK") > 0 Then
            ActiveWorkbook.FollowHyperlink extractHypFromFormula(ActiveCell.Formula)
        End If
    Next
End Sub

Function extractHypFromFormula(strForm As String) As String
    Dim Hpos As Long, startP As Long, Hlength As Long, strRoot As String
    Dim startP2 As Long, cellsAddr As String
    Hpos = InStr(strForm, "HYPERLINK") 'it returns position of the first character for "HYPERLINK" string in the formula
    If Hpos > 0 Then
         startP = Hpos + Len("HYPERLINK") + 2 'it builds the position after which to start searching
                                                               '+ 2 because of '(' and "
         Hlength = InStr(startP, strForm, """") - startP 'length of the hyperlink fix part (before the strings taken from the two cells value)
         strRoot = Mid(strForm, startP, Hlength) 'it returns the hyperlink fix part
         startP2 = startP + Len(strRoot) + 2      'next START to return the string keeping the concatenation of the two cells value
         cellsAddr = Mid(strForm, startP2, InStr(startP2, strForm, ",") - startP2) 'the string keeping the concatenation of the two cells value
         'split the string on "&" separator and use the two elements as range string:
         extractHypFromFormula = strRoot & Range(Split(cellsAddr, "&")(0)).value & Range(Split(cellsAddr, "&")(1)).value
    End If
End Function

Please, send some feedback after testing it...