在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 Worksheet函數創建，並且該文本未顯示鏈接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" =HYPERLINK("www."&"Google"&".Com","Google") ，然后將其作為公式存儲在該單元格中
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