Hyperlink Error handling challenges.

[imadoofus]

Trying to go through a long list of hyperlinks to see if they exist, if not highlight and tally. No popups or warnings ideally.
Not much vba background, so the existing code has been cobbled together from a few forums.
Can't seem to get it to work.
I am doing something blatantly obvious that is wrong?
Thanks for your help!


Sub check_links()


Dim tt_file As String
Dim file_ct As Integer: file_ct = 1 'Starting row for server locations
Dim file_ok As Integer: file_ok = 0
Dim file_missing As Integer: file_missing = 0


Dim wb As Workbook


Worksheets("Locations").Cells.ClearFormats

'''''' File or Web location operations
tt_file = "init"
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While tt_file <> ""
tt_file = Worksheets("Locations").Range("A" & file_ct).Value
'MsgBox tt_file
On Error Resume Next
Set wb = Workbooks.Open(tt_file)
On Error GoTo 0


If Not wb Is Nothing Then
file_ok = file_ok + 1
wb.Close savechanges:=False
Else
file_missing = file_missing + 1
Sheets("Locations").Cells(file_ct, 1).Interior.Color = RGB(255, 255, 0) 'Yellow
End If


GoTo UPDATECTR


'Handler: file_missing = file_missing + 1
'MsgBox "filemissing"
'Sheets("Locations").Cells(file_ct, 1).Interior.Color = RGB(255, 255, 0) 'Yellow


UPDATECTR: file_ct = file_ct + 1


Loop
Application.DisplayAlerts = True
MsgBox "Links fine : " & file_ok & " Missing links : " & file_missing & " (highlighted)"


End Sub

[Leith Ross]

Hello imadoofus,

Does the each cell contain the full workbook path or is it a hyperlink to the workbook?

[imadoofus]

Each cell is a direct link to the .xlsx file. opening and closing has not been an issue and I am doing that in other parts of the code.
20% of the links are wrong, and everytime the code hits one of those it stops with a pop-up. I am trying to work around that.

[Leith Ross]

Hello imadoofus,

Just so I am clear on this, each cell is hyperlink to the workbook. That is the cell contents are in blue font and underlined, yes?

[Leith Ross]

Hello imadoofus,

Try this amended version of your code...


Sub check_links()

Dim tt_file As String
Dim file_ct As Integer: file_ct = 1 'Starting row for server locations
Dim file_ok As Integer: file_ok = 0
Dim file_missing As Integer: file_missing = 0

Dim Cell As Range
Dim Rng As Range
Dim RngBeg As Range
Dim RngEnd As Range
Dim wb As Workbook
Dim Wks As Worksheet


Set Wks = ThisWorkbook.Worksheets("Locations")
Wks.Cells.ClearFormats

'''''' File or Web location operations
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set RngBeg = Wks.Range("A1")
Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp)
If RngEnd.Row < RngBeg.Row Then Set RngEnd = RngBeg

For Each Cell In Wks.Range(RngBeg, RngEnd)
If Cell.Hyperlinks.Count > 0 Then
tt_file = Cell.Hyperlinks(1).Address
file_ct = file_ct + 1
On Error Resume Next
Workbooks.Open tt_file
If Err = 0 Then
file_ok = file_ok + 1
wb.Close savechanges:=False
Else
file_missing = file_missing + 1
Wks.Cells(file_ct, 1).Interior.Color = RGB(255, 255, 0) 'Yellow
End If
On Error GoTo 0
End If
Next Rng

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Links fine : " & file_ok & " Missing links : " & file_missing & " (highlighted)"

End Sub

[imadoofus]

Ah, thanks.
No, these are not blue direct hyperlinks.

For instance this is one of my links -> https://www.pmisserver.org/ProjectDocuments/International Waters/Africa - (9160) - Regional Partnership for African Fisheries Policy/06-26-15__IW_Tracking_Tool_rev.xls

I combined your code with some of mine (took out the hyperlink references) and now get the "Subscript out of range" error. String is too long?

[imadoofus]

Resolved. Post-caffeine poking around helped. Here is the final successful code for anyone else that might need it.






Sub check_links()


Dim tt_file As String
Dim file_ct As Integer: file_ct = 1 'Starting row for filenames/PMIS locations
Dim file_ok As Integer: file_ok = 0
Dim file_missing As Integer: file_missing = 0


Dim Cell As Range
Dim Rng As Range
Dim RngBeg As Range
Dim RngEnd As Range
Dim wb As Workbook
Dim Wks As Worksheet

Set Wks = ThisWorkbook.Worksheets("Locations")
Wks.Cells.ClearFormats




'''''' File or Web location operations
tt_file = "init"
Application.ScreenUpdating = False
Application.DisplayAlerts = False



Set RngBeg = Wks.Range("A1")
Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp)
If RngEnd.Row < RngBeg.Row Then Set RngEnd = RngBeg


For Each Cell In Wks.Range(RngBeg, RngEnd)
tt_file = Wks.Range("A" & file_ct).Value
file_ct = file_ct + 1
On Error Resume Next
Set wb = Workbooks.Open(tt_file)
If Err = 0 Then
file_ok = file_ok + 1
wb.Close savechanges:=False
Else
file_missing = file_missing + 1
Wks.Cells(file_ct, 1).Interior.Color = RGB(255, 255, 0) 'Yellow
End If
On Error GoTo 0
Next


Application.DisplayAlerts = True
MsgBox "Links fine : " & file_ok & " Missing links : " & file_missing & " (highlighted)"


End Sub

[Leith Ross]

Hello imadoofus,

Congratulations on solving the problem. I just woke up a half an hour ago and can relate to the need for caffeine. Glad I could help.