在 Excel 中使用 VBA 打开超链接（运行时错误 9）

Question

我正在尝试使用 VBA 通过以下代码从我的 excel 打开超链接：

numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
    ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
    numRow = numRow + 1
Loop

但是，我在代码中跟随超链接的位置不断收到Runtime Error 9: Subscript out of range。

我对 VBA 宏制作还很陌生（就像“以前从未做过”一样），因此我们将不胜感激。 （如果有更好的方法从单个列中的每个单元格打开链接，我也很感激学习）

编辑（添加更多信息）

有问题的超链接是使用 HYPERLINK 工作表函数创建的，文本不显示链接 URL。工作表数据示例如下：

它看起来像什么

案例 ------ 链接
案例1-----总结
案例2-----总结
案例3-----总结

然而，显示文本“摘要”的单元格包含一个公式

=HYPERLINK("whateverthebaseurlis/"&[@[Case]]&"/Summary", "Summary")

这是必须遵循的链接。该链接有效，可以手动跟踪。但我需要通过宏来完成

谢谢

Answer 1

您可能会遇到错误，因为您有一些带有文本但没有链接的单元格！

检查链接而不是单元格是否为文本：

numRow = 1
Do While ActiveSheet.Range("E" & numRow).Hyperlinks.Count > 0
    ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
    numRow = numRow + 1
Loop

Answer 2

如果它在您尝试打开超链接时抛出错误，请尝试使用 explorer.exe 显式打开它

Shell "explorer.exe " & Range("E" & numRow).Text

Hyperlinks(1).Follow 不起作用的原因是单元格中没有常规的超链接，因此它会返回超出范围

numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
    URL = Range("E" & numRow).Text
    Shell "C:\Program Files\Internet Explorer\iexplore.exe " & URL, vbNormalNoFocus
    numRow = numRow + 1
Loop

查看此帖子是否有类似问题： http://www.mrexcel.com/forum/excel-questions/381291-activating-hyperlinks-via-visual-basic-applications.html

Answer 3

久经考验

假设

我在这里介绍 3 个场景，如 Excel 文件所示。

1. =HYPERLINK("www."&"Google"&".Com","Google")。此超链接有一个好记的名称
2. www.Google.com普通超链接
3. =HYPERLINK("www."&"Google"&".Com")此超链接没有友好名称

截图：

逻辑：

1. 检查它是什么类型的超链接。如果它不是具有友好名称的代码，则代码非常简单
2. 如果超链接有一个友好的名称，那么代码会尝试从 =HYPERLINK("www."&"Google"&".Com","Google") 中提取文本 "www."&"Google"&".Com"，然后将其作为公式存储在该单元格中
3. 一旦公式将上述文本转换为普通超链接，即没有友好名称，然后我们使用 ShellExecute 打开它
4. 重置单元格的原始公式

代码：

Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal Operation As String, _
ByVal Filename As String, Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long

Sub Sample()
    Dim sFormula As String
    Dim sTmp1 As String, sTmp2 As String
    Dim i As Long
    Dim ws As Worksheet

    '~~> Set this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets(1)

    i = 1

    With ActiveSheet
        Do While WorksheetFunction.IsText(.Range("E" & i))
            With .Range("E" & i)
                '~~> Store the cells formula in a variable for future use
                sFormula = .Formula

                '~~> Check if cell has a normal hyperlink like as shown in E2
                If .Hyperlinks.Count > 0 Then
                    .Hyperlinks(1).Follow
                '~~> Check if the cell has a hyperlink created using =HYPERLINK()
                ElseIf InStr(1, sFormula, "=HYPERLINK(") Then
                    '~~> Check if it has a friendly name
                    If InStr(1, sFormula, ",") Then
                        '
                        ' The idea here is to retrieve "www."&"Google"&".Com"
                        ' from =HYPERLINK("www."&"Google"&".Com","Google")
                        ' and then store it as a formula in that cell
                        '
                        sTmp1 = Split(sFormula, ",")(0)
                        sTmp2 = "=" & Split(sTmp1, "HYPERLINK(")(1)

                        .Formula = sTmp2

                        ShellExecute 0, "Open", .Text

                        '~~> Reset the formula
                        .Formula = sFormula
                    '~~> If it doesn't have a friendly name
                    Else
                        ShellExecute 0, "Open", .Text
                    End If
                End If
            End With
            i = i + 1
        Loop
    End With
End Sub

Answer 4

获取单元格超链接的更简洁方法：

使用Range.Value(xlRangeValueXMLSpreadsheet)，可以获取XML 中的单元格超链接。因此，我们只需要解析 XML。

'Add reference to Microsoft XML (MSXML#.DLL)
Function GetHyperlinks(ByVal Range As Range) As Collection
    Dim ret As New Collection, h As IXMLDOMAttribute
    Set GetHyperlinks = ret
    With New DOMDocument
        .async = False
        Call .LoadXML(Range.Value(xlRangeValueXMLSpreadsheet))
        For Each h In .SelectNodes("//@ss:HRef")
            ret.Add h.Value
        Next
    End With
End Function

所以你可以在你的代码中使用这个函数：

numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
    FollowHyperlink GetHyperlinks(ActiveSheet.Range("E" & numRow))
    numRow = numRow + 1
Loop

如果您不需要numRow，您可以：

Dim h as String
For Each h In GetHyperlinks(ActiveSheet.Range("E:E"))
    FollowHyperlink h
Next

对于FollowHyperlink，我建议使用以下代码 - 您可以从其他答案中获得其他选择：

Sub FollowHyperlink(ByVal URL As String)
    Shell Shell "CMD.EXE /C START """" """ & URL & """"
End Sub