Sub Link_Pruefen()
Dim hypLink As Hyperlink
Dim varFehler As Variant
Dim AnzahlFalsch As Integer
Dim LetzteZeile As Integer
LetzteZeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
ActiveSheet.Range(Cells(9, 2), Cells(LetzteZeile, 2)).Interior.ColorIndex = 0
For Each hypLink In ActiveSheet.Range(Cells(9, 2), Cells(LetzteZeile, 2)).Hyperlinks
If TypeName(hypLink.Parent) = "Range" Then
On Error Resume Next
varFehler = Dir(hypLink.Address)
If varFehler = "" Then
varFehler = Err.Number
Else
varFehler = Dir(hypLink.Address)
End If
On Error GoTo 0
If Not IsNumeric(varFehler) Then
hypLink.Parent.Interior.ColorIndex = 4
Else
hypLink.Parent.Interior.ColorIndex = 3
AnzahlFalsch = AnzahlFalsch + 1
End If
End If
Next
MsgBox AnzahlFalsch & " Verlinkungen sind fehlerhaft." & vbCrLf & vbCrLf & "Bitte beheben!", _
vbExclamation, "Defekte Links entdeckt!"
End Sub