Werking hyperlinks in excel controleren mbv macro

[Martijs]

Ik heb een excelbestand met daarin ruim 200 hyperlinks verspreid over circa 80 werkbladen. Nu wil ik een macro maken die de werking van de hyperlinks (interne en externe hyperlinks) op de verschillende werkbladen controleerd en aangeeft welke hyperlinks niet werken.

Weet iemand een script voor zo'n macro?

Via google heb ik 2 verschillende scripts gevonden die zouden moeten werken, maar op de één of andere manier geven ze toch geen resultaat.

De eerste:

Function CheckLinkedStatus()
Dim LinkStatus As XlLinkStatus
Dim ExternalLinksSources() As Variant
Dim I As Integer

ExternalLinksSources = ActiveWorkbook.LinkSources(XlLink.xlExcelLinks)

If IsEmpty(ExternalLinksSources) Then
CheckLinkedStatus = True
End If

For I = LBound(ExternalLinksSources) To UBound(ExternalLinksSources)
LinkStatus = ActiveWorkbook.LinkInfo(ExternalLinksSources(I), xlLinkInfoStatus)

If LinkStatus <> xlLinkStatusOK And LinkStatus <> xlLinkStatusOld Then
CheckLinkedStatus = False

Exit Function
End If
Next I

CheckLinkedStatus = True
End Function

en de andere is:

Sub ChkHypLnks()
Dim wksHypLnks, wksBadHypLnks As Worksheet
Dim curHypLnk As Hyperlink
Dim curFile As String
Dim iBadHypLnks As Integer

Set wksHypLnks = ActiveSheet
Set wksBadHypLnks = ThisWorkbook.Worksheets.Add

wksBadHypLnks.Name = "BadHypLnks" _
& Right(wksBadHypLnks.Name, Len(wksBadHypLnks.Name) - 5)

For Each curHypLnk In wksHypLnks.Hyperlinks
If Dir(curHypLnk.Address) = "" Then
iBadHypLnks = iBadHypLnks + 1
wksBadHypLnks.Cells(iBadHypLnks, 1) = curHypLnk.Address
End If
Next curHypLnk
Application.DisplayAlerts = False
If iBadHypLnks < 1 Then wksBadHypLnks.Delete
Application.DisplayAlerts = True
End Sub

Ik gebruik excel 2003.

Groet,

Martijs

 

[snb]

Jij gebruikt Excel 2003, maar geen code tags als je hier VBA-code plaatst, jammer.
Evenmin heb je een voorbeeldbestand geplaatst. Dat zou de beantwoording een stuk makkelijker kunnen maken.
Kun je beide nog even doen ?

Deze code is voldoende:

Sub tst4()
  On Error Resume Next
  For Each hp In Sheets(1).Hyperlinks
    hp.Follow
    If Err.Number <> 0 Then c01 = c01 & "|" & hp.Address & "_" & hp.TextToDisplay
    Err.Clear
  Next
  Sheets(1).Cells(1, 10).Resize(UBound(Split(c01, "|")) + 1) = WorksheetFunction.Transpose(Split("foute boel" & c01, "|"))
End Sub