Check broken external hyperlinks

[neagu_2003]

Hi,


I have a spreadsheet with a list of forms (Col A) and the next column contains the URL address (hyperlink) to the form (Col B)

From time to time I need to check the file for broken links, as some of the forms could be removed from their location. The list is huge with thousand of lines.


Is there a way to automate this task to automatically check for broken links?

Thanks

 

[neagu_2003]

Is this impossible, or none of you faced yet this issue?

 

[Hui]

Neagu

Try copy and paste the following code into a code module in VBA

It assumes that

Column A has a List of names

Column B has a List of Hyperlinks

Adjust ranges in For Each row to suit


This version will show you the Dead Hyperlinks and Shade them Yellow

[pre]

Option Explicit
Sub DeadHyperlinks()
'
' Find Dead Hyperlinks
' by
' Hui
'
Dim c As Range

For Each c In Worksheets("Sheet1").Range("B1:B10") 'Change range to suit

If c.Value = "" Then End

If FileExists(c.Hyperlinks(1).Address) = "False" Then
MsgBox "Row " + Str(c.Row) + " - " + Cells(c.Row, 1) + " Is Dead" 'Display message if dead
With c.Interior 'Color cell with dead link Yellow
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With

End If
Next

End Sub

Function FileExists(PathName As String) As Boolean

Dim Temp As Integer

On Error Resume Next      'Ignore errors

Temp = GetAttr(PathName)

Select Case Err.Number      'Check if error exists and set response
Case Is = 0
FileExists = True
Case Else
FileExists = False
End Select

On Error GoTo 0      'Resume error checking

End Function

[/pre]

 

[Hui]

This version will find and delete the entire row of a Dead Hyperlink


Make sure you backup first

[pre]

Option Explicit

Sub DeadHyperlinks()
'
' Find and Delete, Dead Hyperlinks
' by
' Hui
'
Dim WS As String
Dim rng As Range
Dim i As Integer
Dim j As Integer
j = 0
WS = "Sheet1" 'set worksheet name

Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(1))

For i = rng.Count To 1 Step -1
If Worksheets(WS).Cells(i, 2).Value <> "" Then
If FileExists(Worksheets(WS).Cells(i, 2).Hyperlinks(1).Address) = "False" Then
j = j + 1
Worksheets(WS).Cells(i, 1).EntireRow.Delete
End If
End If
Next

MsgBox Str(j) + " rows deleted"

End Sub

Function FileExists(PathName As String) As Boolean

Dim Temp As Integer

On Error Resume Next      'Ignore errors

Temp = GetAttr(PathName)

Select Case Err.Number      'Check if error exists and set response
Case Is = 0
FileExists = True
Case Else
FileExists = False
End Select

On Error GoTo 0      'Resume error checking

End Function

[/pre]

Note: The 2 Macros above will not work for Web Hyperlinks only Local and Network File Hyperlinks

 

[shrutikul.07]

Hi Chandu


I have difficulty in doing a hyperlink from word to excel.

My Screen shots of a application is in word and

I have to hyperlink that screen shot of particular screen

in excel.


Please Help me.

 

[Hui]

Shrutikul

If I Use a Formula based Hyperlink in Excel

=HYPERLINK("[C:UsersHuiDesktopMy Budget.docx]Budget","Open at Budget")


I will have a hyperlink c alled "Open at Budget"

It will open the word document "My Budget.docx"

On my destop

at a Bookmark called "Budget"


You have to define the Bookmarks in your word document first


ps: Please start new questions in new posts.

 

[dizzitelli]

Hi Hui,


thanks for your code! Expecially for the one that show you the Dead Hyperlinks and Shade them Yellow it can be very usefull, but in my case it doesn't work...


I've change the range to suit in this way:

"For Each c In Worksheets("STP0001-atto aggiuntivo").Range("h76:h5000") 'Change range to suit"

but it doesn't show any yellow cells.


In the column H of the sheet "STP0001-atto aggiuntivo" I've the hyperlinks..


Thank you in advance,

regards,


Luca

 

[dizzitelli]

I've forgot an important think...all the Hyperlinks are similar to this one

anconadatiufficio tecnicoelaboratiProgetto EsecutivoPDFfile.pdf

they are made into a local folder..and most of it it work well..