Hyperlinks auf ziel prüfen
15.02.2022 12:45:27
Janett
mit folgendem Code sollen Hyperlinks geprüft und wenn nicht vorhanden die entsprechende Zell farbig markiert werden (datei vorhanden oder nicht).
Wenn ich die Hyperlinks so verändere das die vollständige Adresse angegeben ist (R:\kst\kunde\Sonder\06_KW\test.pdf) funktioniert das Ganze auch super.
Nach dem Speichern und öffnen ändert Excel die links aber wieder in 06_KW/test.pdf und mir werden alle Zellen als nicht vorhanden angezeigt.
Hat jemand eine Idee?
LG Janett
Sub HyperlinkTest()
Worksheets("Monatsübersicht").Unprotect "****"
' Testet Hyperlink-Formeln und direkt verlinkte Dateien auf Vorkommen im aktiven Blatt
Dim rC As Range
Dim HL As Hyperlink
Dim lHLX As Long
Dim strDatei As String
' Testen der Hyperlink Formeln
On Error Resume Next
Set rC = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rC Is Nothing Then
For Each rC In ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
If Left(rC.Formula, 11) = "=HYPERLINK(" Then
strDatei = Dir(Replace(Split(Mid(rC.Formula, 12), ",")(0), """", ""))
If strDatei = "" Then rC.Interior.ColorIndex = 3
End If
Next rC
Else
MsgBox "Keine Formeln im aktiven Blatt!", vbOKOnly + vbExclamation, ActiveSheet.Name
End If
' Testen von direkten Hyperlinks im aktiven Blatt
If ActiveSheet.Hyperlinks.Count > 0 Then
For Each HL In ActiveSheet.Hyperlinks
strDatei = Dir(HL.Address)
If strDatei = "" Then HL.Range.Interior.ColorIndex = 3
Next HL
Else
MsgBox "Keine direkten Hyperlinks im aktiven Blatt!", vbOKOnly + vbExclamation, ActiveSheet.Name
End If
MsgBox "markierung entfernen", vbOKOnly + vbExclamation, ActiveSheet.Name
Range("Daten2[Datei]").Select
ActiveWindow.SmallScroll Down:=-45
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveWindow.SmallScroll Down:=-9
Range("A2").Select
Worksheets("Monatsübersicht").Protect "****", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, AllowInsertingHyperlinks:=True
End Sub