[英]Open Hyperlinks Using VBA in Excel (Runtime Error 9)
I am trying to use VBA to open hyperlinks from my excel using the following code: 我正在尝试使用VBA使用以下代码从我的excel中打开超链接:
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
numRow = numRow + 1
Loop
However, I keep getting Runtime Error 9: Subscript out of range
at the point in the code where I follow the hyperlinks. 但是,在代码中我遵循超链接的那一点上,我一直在遇到
Runtime Error 9: Subscript out of range
情况。
I'm pretty new to VBA Macro-making (as in-'never done it before'), so help would be appreciated. 我对VBA宏制作非常陌生(就像以前从未做过的一样),因此将不胜感激。 (And if there's a better way to open a link from each cell in a single column, I'd appreciate learning about that too)
(如果有更好的方法可以打开单个列中每个单元格的链接,我也很高兴了解到这一点)
EDIT (To add more Info) 编辑(添加更多信息)
The hyperlink in question has been created using HYPERLINK Worksheet function and the text does not display the link URL. 该超链接已使用HYPERLINK Worksheet函数创建,并且该文本未显示链接URL。 Sample of worksheet data is something like this:
工作表数据样本如下所示:
What It Looks Like 看起来像什么
Case ------ Link 案例 ------ 链接
Case1----- Summary 案例1 -----总结
Case2----- Summary 案例2 -----摘要
Case3----- Summary 案例3 -----总结
The Cells showing the text "Summary", however, contain a formula 但是,显示文本“摘要”的单元格包含一个公式
=HYPERLINK("whateverthebaseurlis/"&[@[Case]]&"/Summary", "Summary")
And this is the link that has to be followed. 这是必须遵循的链接。 The link works, it can be followed manually.
该链接有效,可以手动跟随。 But I need to do it via macro
但是我需要通过宏来做
Thanks 谢谢
Probably, you are getting error because you have some cells with text but no link! 可能因为您有一些带有文本但没有链接的单元格而出现错误!
Check for link instead of whether or not cell is text: 检查链接而不是单元格是否为文本:
numRow = 1
Do While ActiveSheet.Range("E" & numRow).Hyperlinks.Count > 0
ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
numRow = numRow + 1
Loop
If it is throwing the error where you try to open hyperlinks, try and explictly open it using explorer.exe 如果在尝试打开超链接时引发错误,请尝试使用explorer.exe明确打开它。
Shell "explorer.exe " & Range("E" & numRow).Text
the reason Hyperlinks(1).Follow
not working is that is no conventional hyperlink in the cell so it will return out of range 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
Check this post for a similar problem: http://www.mrexcel.com/forum/excel-questions/381291-activating-hyperlinks-via-visual-basic-applications.html 检查此帖子是否有类似问题: http : //www.mrexcel.com/forum/excel-questions/381291-activating-hyperlinks-via-visual-basic-applications.html
TRIED AND TESTED 经过测试
Assumptions 假设条件
I am covering 3 scenarios here as shown in the Excel file. 我将在此处介绍3种情况,如Excel文件所示。
=HYPERLINK("www."&"Google"&".Com","Google")
. =HYPERLINK("www."&"Google"&".Com","Google")
。 This hyperlink has a friendly name www.Google.com
Normal hyperlink www.Google.com
普通超链接 =HYPERLINK("www."&"Google"&".Com")
This hyperlink doesn't have a friendly name =HYPERLINK("www."&"Google"&".Com")
此超链接没有友好名称 Screenshot: 屏幕截图:
Logic: 逻辑:
"www."&"Google"&".Com"
from =HYPERLINK("www."&"Google"&".Com","Google")
and then store it as a formula in that cell =HYPERLINK("www."&"Google"&".Com","Google")
提取文本"www."&"Google"&".Com"
=HYPERLINK("www."&"Google"&".Com","Google")
,然后将其作为公式存储在该单元格中 ShellExecute
ShellExecute
打开它 Code: 码:
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
A cleaner way of getting cells hyperlinks: 获取单元超链接的一种更干净的方法:
Using Range.Value(xlRangeValueXMLSpreadsheet)
, one can get cell hyperlink in XML. 使用
Range.Value(xlRangeValueXMLSpreadsheet)
,可以获取XML中的单元超链接。 As so, we only have to parse 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
So you can use this function in your code as this: 因此,您可以在代码中使用此功能,如下所示:
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
FollowHyperlink GetHyperlinks(ActiveSheet.Range("E" & numRow))
numRow = numRow + 1
Loop
If you don't need numRow
, you can just: 如果您不需要
numRow
,则可以:
Dim h as String
For Each h In GetHyperlinks(ActiveSheet.Range("E:E"))
FollowHyperlink h
Next
For FollowHyperlink
, I suggest below code - you have other options from another answers: 对于
FollowHyperlink
,我建议使用以下代码-您可以从其他答案中选择其他选项:
Sub FollowHyperlink(ByVal URL As String)
Shell Shell "CMD.EXE /C START """" """ & URL & """"
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.