使用VBA在Excel中排除无效的超链接？

标题说：

我有一个超级链接列的Excel表单。 现在我想要一个VBA脚本检查哪些超链接已经死了或工作，并使用404错误或活动的文本进入下一列。

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

编辑：

我发现@ http://www.utteraccess.com/forums/printthread.php?Cat=&Board=84&main=1037294&type=thread

这是一个解决scheme，但是问题是，我需要这个解决scheme的Excel。 有人可以把它转换成Excel解决scheme吗？

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 

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 

Answer 2

Gary的代码是完美的，但我宁愿在一个模块中使用一个公共函数，并将其作为函数在单元中使用。 好处是您可以在您select的单元格或其他更复杂的function中使用它。

在下面的代码中，我调整了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 – > Insert – > Module）并将代码粘贴到模块中。

Option Explicit Public Function CheckHyperlink(ByVal strUrl As String) As Boolean Dim oHttp As New MSXML2.XMLHTTP30 On Error GoTo ErrorHandler oHttp.Open "HEAD", strUrl, False oHttp.send If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True Exit Function ErrorHandler: CheckHyperlink = False End Function
Option Explicit Public Function CheckHyperlink(ByVal strUrl As String) As Boolean Dim oHttp As New MSXML2.XMLHTTP30 On Error GoTo ErrorHandler oHttp.Open "HEAD", strUrl, False oHttp.send If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True Exit Function ErrorHandler: CheckHyperlink = False End Function 

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