Verfügbarkeit von Web-Links mit VBA prüfen
15.08.2016 21:16:38
Web-Links
Ich habe in Excel eine Liste von Links zu Dokumenten auf einem firmeninternen Server. Diese Dokumente sind auf einem Share Point gespeichert werden aber auf diversen Seiten verlinkt. Durch neuere Versionen der Dokumente kann es passieren, dass ein Link nicht mehr richtig funktioniert, daher möchte ich gerne per VBA Abfrage meine URL-Liste überprüfen lassen und funktionsfähige Links in grün und kaputte Links rot einfärben.
Meine VBA-Kenntnisse sind stark eingerostet und habe mich durch das ganze Web gesucht und alles mögliche probiert.
Momentan ist der folgende Code in Verwendung. Jedoch funktioniert er nicht korrekt. Entweder werden alle Links als "ok" angezeigt, oder alle sind rot.
Auch nach verfälschen einiger zuvor "korrekter" Links zeigt mir das Makro die Links immer noch als okay an.
Jetzt gerade funktioniert es wieder nicht.
Zum Testen versuche ich "https://www.google.de" aber selbst der Link ist angeblich defekt.
Habt ihr einen neuen Vorschlag?
Sub Link_Pruefen()
Dim hypLink As Hyperlink
Dim varFehler As Variant
Dim AnzahlFalsch As Integer
Dim LetzteZeile As Integer
'Bestimmen der Letzten Zeile in Spalte B
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