Sort dead hyperlinks in Excel using VBA?

Question

The title reads:

I have an excel sheet with a column full of hyperlinks. Now I want VBA Script to check which hyperlinks are dead or working, and write to the following columns with either 404 Error or Active text.

Hope someone can help me because I'm not very good at VB.

EDIT:

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

The solution that is made for the word, but the problem is that I need this solution for Excel. Can someone translate this into an excel solution?

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

First add a link to Microsoft XML V3 (or higher) using Tools-> References. Then paste this code:

 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

The Gary code is perfect, but I would rather use a public function in a module and use it as a function. The advantage is that you can use it in a cell of your choice or in any other more complex function.

In the code below, I adjusted the Gary code to return a boolean, and you can use this output in the format = IF (CHECKHYPERLINK (A1), "OK", "FAILED"). Alternatively, you can return Integer and return the status itself (for example: = IF (CHECKHYPERLINK (A1) = 200; "OK", "FAILED"))

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

To use this code, follow the Gary instructions and optionally add the module to the book (right-click on the VBAProject → Insert → module) and paste the code into the 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 

Also remember that if the page does not work, the wait time may be long.