relative Hyperlinks auf Funktionsfähigkeit prüfen

  • Excel

Es gibt 10 Antworten in diesem Thema. Der letzte Beitrag () ist von Joarden.

    relative Hyperlinks auf Funktionsfähigkeit prüfen

    Hallo Zusammen,

    vorab, ich habe die SuFu genutzt, konnte mein Problem damit jedoch nicht lösen und bin langsam am verzweifeln.

    Ich möchte Hyperlinks (PDF`s) auf Funktionsfähigkeit testen und bei false die Zelle rot markieren und den Inhalt auf "leer" setzen .Bei true soll die Zelle nur grün hinterlegt werden. Der Link kann stehen bleiben.
    Leider funktioniert das mit dem Makro, welches ich nutzen möchte nicht ganz.
    Mit VBA habe ich mich erst seit drei Tagen, aufgrund dieses Problems, beschäftigt. Daher habe ich nicht wirklich viel Hintergrundwissen.

    Die Exceltabelle und Ordnerstruktur sehen wie folgt aus:


    Hier sollen jetzt alle Links von "C8:G1000" auf funktionalität geprüft werden und entsprechend eingefärbt werden.
    Es handelt sich immer nur um PDF´s nach dem Schema "LEB_xxxx.xxx.xxx.pdf" ). Die Struktur habe ich in den Anhang getan!
    PS: Falls es wichtig ist. die Pfade im Netzwerk sehen wie folgt aus \\emea.test.com\XXX\TeamXY\Dokumente

    Bisher habe ich nur ein Script, welches absolute, jedoch keine relativen, Links prüfen kann:

    Quellcode

    1. Option Explicit
    2. Option Compare Text
    3. Sub hyperlinksTesten()
    4. Dim HyperL As Hyperlink, Addresse As String, t As String
    5. Dim fso As Object, rng As Range
    6. Set fso = CreateObject("Scripting.FileSystemObject")
    7. For Each HyperL In ActiveSheet.Hyperlinks
    8. If Not HyperL.Address Like "*\*" Then
    9. Addresse = ActiveWorkbook.Path & "\" & HyperL.Address
    10. Else
    11. Addresse = HyperL.Address
    12. End If
    13. ' Addresse = "Test"
    14. If Not fso.FolderExists(Addresse) And Not fso.FileExists(Addresse) Then
    15. Set rng = HyperL.Range
    16. t = rng.Text
    17. HyperL.Delete
    18. rng.Value = "ERROR: " & t
    19. rng.Font.ColorIndex = 3
    20. End If
    21. Next
    22. Set fso = Nothing
    23. End Sub


    Ich wäre über Hilfe sehr Dankbar!

    Gruß,
    Joarden
    Dateien
    macht das nicht bereits diese Zeile?
    und sobald ich aus der Formel den Punkt entferne, geht ja der Hyperlink nicht mehr...

    Quellcode

    1. Addresse = ActiveWorkbook.Path & "\" & HyperL.Address

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Joarden“ ()

    petaod schrieb:

    Es sagt ja keiner, du sollst den Hyperlink verändern.
    Du sollst in der Prüfadresse den Punkt durch den Pfad ersetzen.


    Sorry, ich hatte da wohl ein Verständnisproblem. Leider funktioniert es jedoch immer noch nicht.
    Irgendwo muss noch ein Fehler sein... .

    PS: Wenn ich mit dem Mauszeiger über HyperL.Address fahre kommt "HyperL.Address = <Objektvariable oder With-Blockvariable nicht festgelegt>"
    Falls dies wichtig ist.

    Joarden schrieb:

    Objektvariable oder With-Blockvariable nicht festgelegt
    In welcher Zeile?
    Zeig mal deinen aktuellen Code.

    Was zeigt denn HyperL sonst noch für Properties? Ist das am Objekt Ende gar Nothing? Wie kommt es dann in die Collection?

    8| Könnte es sein, dass du eine erwischt hast, den du bereits gelöscht hast?
    Möglicherweise musst du von hinten nach vorne durch die Collection loopen, damit das nicht passiert.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --


    Es werden keine anderen properties angezeigt... Zum Testen habe ich sogar Beispieldokumente hinterlegt, egal ob am Anfang oder Ende, anscheinend kommen die garnicht in die collection :(.

    Quellcode

    1. Option Explicit
    2. Option Compare Text
    3. Sub hyperlinksTesten()
    4. Dim HyperL As Hyperlink, Addresse As String, t As String
    5. Dim fso As Object, rng As Range
    6. Set fso = CreateObject("Scripting.FileSystemObject")
    7. For Each HyperL In ActiveSheet.Hyperlinks
    8. If Not HyperL.Address Like "*.\*" Then
    9. Addresse = ActiveWorkbook.Path & HyperL.Address
    10. Else
    11. Addresse = HyperL.Address
    12. End If
    13. If Not fso.FolderExists(Addresse) And Not fso.FileExists(Addresse) Then
    14. Set rng = HyperL.Range
    15. t = rng.Text
    16. HyperL.Delete
    17. rng.Value = "ERROR: " & t
    18. rng.Font.ColorIndex = 3
    19. End If
    20. Next
    21. Set fso = Nothing
    22. End Sub
    Dateien
    In Zeile 9 ist natürlich HyperL noch nicht belegt.
    Wie sieht es denn in Zeile 10 aus?

    Ansonsten kannst du vermutlich Zeile 10-14 durch diese ersetzen:
    Addresse = Replace(HyperL.Address, ".\", ActiveWorkbook.Path & "\")

    Joarden schrieb:

    If Not fso.FolderExists(Addresse) And Not fso.FileExists(Addresse) Then
    Da möchte ich mal behaupten, dass die Folder-Abfrage überflüssig ist und die File-Abfrage reicht.


    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „petaod“ ()

    Danke erstmal für deine Hilfe petaod!
    Der Code sieht jetzt so aus:

    Quellcode

    1. ​Option Explicit
    2. Option Compare Text
    3. Sub hyperlinksTesten()
    4. Dim HyperL As Hyperlink, Addresse As String, t As String
    5. Dim fso As Object, rng As Range
    6. Set fso = CreateObject("Scripting.FileSystemObject")
    7. For Each HyperL In ActiveSheet.Hyperlinks
    8. Addresse = Replace(HyperL.Address, ".\", ActiveWorkbook.Path & "\")
    9. If Not fso.FileExists(Addresse) Then
    10. Set rng = HyperL.Range
    11. t = rng.Text
    12. HyperL.Delete
    13. rng.Value = "ERROR: " & t
    14. rng.Font.ColorIndex = 3
    15. End If
    16. Next
    17. Set fso = Nothing
    18. End Sub


    Lass ich das Modul laufen, tut sich jedoch nichts. Keine der Links wird rot hinterlegt :-/
    Hallo nochmal,

    ich habe mich nun einige Tage in VBA geschult und bin jetzt etwas schlauer :).
    Das Problem habe ich jetzt etwas eleganter gelöst:

    Ich lasse mir alle Dateien der Ordner 1,2,3,4 in jeweils einer Spalte darstellen:
    LEB_111.111.111HSA_111.111.111
    QAF_111.111.111
    TAF_111.111.111
    LEB_111.111.112
    HSA_111.111.112
    QAF_111.111.112
    TAF_111.111.112
    LEB_111.111.113
    HSA_111.111.113
    QAF_111.111.113
    TAF_111.111.113

    Visual Basic-Quellcode

    1. Option Explicit
    2. Sub listFolderFiles()
    3. Dim zeile As Variant
    4. Dim sFile As String, sPattern As String, sPath As String
    5. Dim iRow As Integer
    6. sPath = "absoluter pfad"
    7. If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    8. sPattern = "*.*"
    9. sFile = Dir(sPath & sPattern)
    10. Do Until sFile = ""
    11. iRow = iRow + 1
    12. Cells(iRow, 1).Value = sFile
    13. sFile = Dir()
    14. Loop
    15. For zeile = 1 To Cells.SpecialCells(xlLastCell).Row
    16. Next
    17. MsgBox "Das ausgewählte Macro wurde erfolgreich ausgeführt!"
    18. End Sub


    danach vergleiche ich einfach mit sverweis und lasse mir den Hyperlink erstellen.

    EDIT: Die Dateiendungen schneide ich mit diesem Code weg:

    Visual Basic-Quellcode

    1. ​Sub cutFormat1()
    2. Dim zeile As Variant
    3. For zeile = 1 To Cells.SpecialCells(xlLastCell).Row
    4. If InStr(1, Range("A" & zeile), ".") > 0 Then
    5. Range("A" & zeile) = Left(Range("A" & zeile), InStrRev(Range("A" & zeile), ".") - 1)
    6. End If
    7. Next
    8. End Sub


    Gruß,
    Joarden

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Joarden“ ()