使用VBA在Excel中对死链接进行排序？

Question

标题已经说明了问题：

我有一个包含超链接的excel表格。现在我想用VBA脚本检查哪些超链接是失效的，哪些是有效的，并在下一列中进行记录，分别用文本“404错误”或“活动”表示。

希望有人能帮助我，因为我不太擅长VB。

编辑：

我在这里找到了一个针对Word的解决方案，但问题是我需要这个解决方案适用于Excel。有人能把它翻译成Excel解决方案吗？

Private Sub testHyperlinks()
    Dim thisHyperlink As Hyperlink
    For Each thisHyperlink In ActiveDocument.Hyperlinks
        If thisHyperlink.Address <> "" And Left(thisHyperlink.Address, 6) <> "mailto" Then
            If Not IsURLGood(thisHyperlink.Address) Then
                Debug.Print thisHyperlink.Address
            End If
        End If
    Next
End Sub


Private Function IsURLGood(url As String) As Boolean
    ' Test the URL to see if it is good
    Dim request As New WinHttpRequest

    On Error GoTo IsURLGoodError
    request.Open "GET", url
    request.Send
    If request.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    Exit Function
IsURLGoodError:
        IsURLGood = False
End Function

- elhombre

---

以上的回答都不错，但我建议小心使用。如果没有一定的延迟，查询大量的URL（超过9000个）可能会对您的DNS造成问题，这是我通过痛苦的经历得出的结论。 - user1108140

Answer 1

首先使用“工具”->“引用”添加对Microsoft XML V3（或更高版本）的引用。然后粘贴以下代码：

Option Explicit

Sub CheckHyperlinks()

    Dim oColumn As Range
    Set oColumn = GetColumn() ' replace this with code to get the relevant column

    Dim oCell As Range
    For Each oCell In oColumn.Cells

        If oCell.Hyperlinks.Count > 0 Then

            Dim oHyperlink As Hyperlink
            Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell

            Dim strResult As String
            strResult = GetResult(oHyperlink.Address)

            oCell.Offset(0, 1).Value = strResult

        End If

    Next oCell


End Sub

Private Function GetResult(ByVal strUrl As String) As String

    On Error Goto ErrorHandler

    Dim oHttp As New MSXML2.XMLHTTP30

    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    GetResult = oHttp.Status & " " & oHttp.statusText

    Exit Function

ErrorHandler:
    GetResult = "Error: " & Err.Description

End Function

Private Function GetColumn() As Range
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function

- Gary McGill

---

非常感谢您提供的完整解决方案！我只有一个问题，某种方式脚本不起作用，我甚至进入了逐步模式（F8），看到脚本没有经过“如果oCell.Hyperlinks.Count>0 Then”循环。它直接进入“End If”表达式循环等。我应该如何解释这样的行为？ - elhombre

@elhombre，你确定它正在查看正确的单元格吗？我的示例代码只查看活动工作簿中第一个工作表中的A列。此外，我假设当你说你有“一个充满超链接的列”时，你指的是单元格实际上是可点击的Excel超链接。如果你只是指单元格值是URL，则可以将所有代码从If到End If剥离并替换为...（见下一条评论）。 - Gary McGill

如果 Trim(oCell.Value) <> ""，则 oCell.Offset(0,1).Value = GetResult(oCell.Value)。 - Gary McGill

你猜对了！这些是带有超链接的可点击单元格，可以在Internet Explorer中打开站点目标。我会查看它是否检查错误的单元格。 - elhombre

抱歉，我必须手动整理一下。但是我认为你的答案是正确的。 - elhombre

+1 做得非常好。可能更容易使用晚期绑定而不是让用户设置引用。 - brettdj

Answer 2

虽然Gary的代码很完美，但我更愿意在模块中使用公共函数，并将其作为函数在单元格中使用。优点是您可以在所选单元格或任何其他更复杂的函数中使用它。

在下面的代码中，我已经调整了Gary的代码以返回布尔值，然后您可以在=IF(CHECKHYPERLINK(A1);"OK";"FAILED")中使用此输出。或者，您可以返回一个整数并返回状态本身（例如：=IF(CHECKHYPERLINK(A1)=200;"OK";"FAILED")）

A1: http://www.whatever.com
A2: =IF(CHECKHYPERLINK(A1);"OK";"FAILED")

要使用此代码，请按照Gary的说明操作，并额外添加一个模块到工作簿中（右键单击VBAProject-->插入-->模块），然后将代码粘贴到模块中。

Option Explicit
'检查超链接是否有效
Public Function CheckHyperlink(ByVal strUrl As String) As Boolean
Dim oHttp As New MSXML2.XMLHTTP30 '声明一个XML HTTP对象用于发送请求
On Error GoTo ErrorHandler '处理错误
    oHttp.Open "HEAD", strUrl, False '将URL放在Open方法中，使用"HEAD"参数来指示仅返回标题而不是响应正文
    oHttp.send '向服务器发送请求
If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True '检查响应状态并返回结果
Exit Function
ErrorHandler:
    CheckHyperlink = False '如果出现错误，则返回false
End Function

请注意，如果页面崩溃，超时时间可能会很长。

- Dynamicbyte

---

它抱怨你写的if语句中有分号。你是不是想用逗号？ - Ape-inago

我认为这取决于您使用的Excel语言版本（或者可能是区域设置？） - Dynamicbyte

@Dynamicbyte：我正在尝试将您的代码添加到Excel 2013（顺便说一句，我为什么还需要Gary的代码？），但在编译时，我在这行oHttp As New MSXML2.XMLHTTP30上收到错误消息“未定义的用户定义类型”...有任何想法吗？这是因为我没有添加对Microsoft XML V3的引用吗？如果是这样，我尝试查找如何做到这一点，但也找不到...：s提前感谢！ - Adam

@Flo: 如果您打开了VBA面板并想要添加引用，请点击「工具」，然后选择「引用」，接着滚动鼠标滚轮直到找到「Microsoft XML V3」。 - Manza