Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1108to1112
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Hyperlink überprüfen

Hyperlink überprüfen
Elmar
Hallo,
Habe in einer Spalte untereinander einige Hyperlinks auf verschiedene pdf-Dokumente.
Ich möchte per vba diese auf Gültigkeit überprüfen lassen. D.h., ob der Link zufinden ist. Ich würde in der nächsten Spalte dies mit einem "OK" anzeigen lassen.
danke für Anregungen

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Hyperlink überprüfen
12.10.2009 13:18:59
Tino
Hallo,
kannst ja mal testen ob es funktioniert.
Spalte, Ausgabebereich und Tabellennamen noch anpassen.
Sub test()
Dim Bereich As Range, LCount
Dim meAr

'wo die Hyperlinks stehen 
With Sheets("Tabelle1")
    Set Bereich = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp))
End With

meAr = Bereich.Offset(0, 1) 'Ausgabebereich 

'Daten prüfen 
For LCount = 1 To Bereich.Hyperlinks.Count
 If Dir(Bereich.Hyperlinks(LCount).Address) <> "" Then
  meAr(Bereich.Hyperlinks(LCount).Range.Row, 1) = "ok."
 Else
  meAr(Bereich.Hyperlinks(LCount).Range.Row, 1) = "nicht ok."
 End If
Next LCount

'Bewertung ausgeben 
Bereich.Offset(0, 1) = meAr

End Sub
Gruß Tino
Anzeige
Kürzer...
12.10.2009 13:44:11
JogyB
Hi.
Tinos Ansatz ist schöner als meiner, ginge aber noch etwas kürzer:
Sub test()
Dim Bereich As Range
Dim meAr
Dim hLink As Hyperlink
' Aktives Arbeitsblatt und Spalte A
With ActiveSheet.Columns(1)
' Ausgabebereich in Array
meAr = .Offset(0, 1)
'Daten prüfen
For Each hLink In .Hyperlinks
meAr(hLink.Range.Row, 1) = IIf(Dir(hLink.Address)  "", "OK", "nicht OK")
Next
'Bewertung ausgeben
.Offset(0, 1) = meAr
End With
End Sub

Gruss, Jogy
AW: Kürzer...
12.10.2009 13:58:35
JogyB
Un weil es Spaß macht, noch eine Variante... hat den Vorteil, dass nicht riesige Array rumgeschleppt werden müssen. Außerdem überschreibt es alle Werte in der Spalte bis auf die Überschriftszeilen, deren Anzahl in der Konstante steht.
Evtl. liessen sich die zwei With Anweisungen zu einer zusammenfassen, nur da Excel 2007 eine variable Anzahl an Zeilen zuläßt, könnte das Rows.Count (dann ohne . vorne) da Probleme machen.
Sub test()
Dim Bereich As Range
Dim meAr() As String
Dim hLink As Hyperlink
' Anzahl der Überschriftzeilen
Const uebRows = 1
' Aktives Arbeitsblatt und Spalte A
With ActiveSheet.Columns(1)
With .Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - uebRows).Offset(uebRows)
' Ausgabebereich in Array
ReDim meAr(uebRows + 1 To .Rows.Count + uebRows)
'Daten prüfen
For Each hLink In .Hyperlinks
meAr(hLink.Range.Row) = IIf(Dir(hLink.Address)  "", "OK", "nicht OK")
Next
'Bewertung ausgeben
.Offset(0, 1) = Application.Transpose(meAr)
End With
End With
End Sub
Gruss, Jogy
Anzeige
noch eine
12.10.2009 14:49:53
Tino
Hallo,
Bereich passt sich automatisch an den definierten Bereich in
Set Bereich = .Range("C2", .Cells(.Rows.Count, 3).End(xlUp)) an.
Allerdings sollte die Spalte nicht leer sein.
Sub test()
Dim Bereich As Range, HyLink As Hyperlink
Dim meAr() As String

With Sheets("Tabelle1")
     Set Bereich = .Range("C2", .Cells(.Rows.Count, 3).End(xlUp))
End With
     
With Bereich
    Redim Preserve meAr(.Cells(1, 1).Row To .Cells(.Rows.Count, 1).Row, 1 To 1)
     
    For Each HyLink In .Hyperlinks
      If Dir(HyLink.Address) <> "" Then
        meAr(HyLink.Range.Row, 1) = "ok."
      Else
        meAr(HyLink.Range.Row, 1) = "nicht ok."
      End If
    Next HyLink
    
    .Offset(0, 1) = meAr
End With

End Sub
Gruß Tino
Anzeige
ganz kurz...
12.10.2009 15:15:42
JogyB
Hi.
Zuerst mal noch ein Nachtrag zu meinen Beispielen: Die Variable Bereich braucht man nicht, hatte ich vergessen rauszunehmen.
Und kürzer kriege ich es jetzt wohl nicht mehr hin:
Sub test()
Dim hLink As Hyperlink
' Aktives Arbeitsblatt und Spalte A
With ActiveSheet.Columns(1)
' Prüft und schreibt Werte in Spalte 2 von Spalte A --> Spalte B
For Each hLink In .Hyperlinks
.Cells(hLink.Range.Row, 2) = _
IIf(Dir(hLink.Address)  "", "OK", "nicht OK")
Next
End With
End Sub
Höchstens noch, indem man sich das With spart, aber das geht auch nur auf die Zeilenzahl und nicht auf die Textlänge.
Sub test()
Dim hLink As Hyperlink
' Prüfen in Spalte A = 1 und schreiben in Spalte B = 2
For Each hLink In ActiveSheet.Columns(1).Hyperlinks
ActiveSheet.Cells(hLink.Range.Row, 2) = _
IIf(Dir(hLink.Address)  "", "OK", "nicht OK")
Next
End Sub
Wobei das bei vielen Links einiges langsamer sein wird als die vorigen Varianten.
Gruss, Jogy
Anzeige
AW: Hyperlink überprüfen
12.10.2009 13:25:21
JogyB
Hi.
Wenn die PDF-Dateien im lokalen Netzwerk oder auf dem Rechner selbst liegen, dann geht es so:
Sub testeHyperlinks()
Dim zeIle As Long
' Spalte die durchsucht wird, hier A
Const sCol = 1
Application.ScreenUpdating = False
' Nimmt das aktive Arbeitsblatt
With ActiveSheet
' Ab Zeile 2, in 1 steht wohl eine Überschrift
For zeIle = 2 To .Cells(Rows.Count, sCol).End(xlUp).Row
' Wenn Hyperlink da
If .Cells(zeIle, sCol).Hyperlinks.Count > 0 Then
' Schauen, ob es den gibt, OK oder Nicht OK eintragen
If Dir(.Cells(zeIle, sCol).Hyperlinks(1).Address)  "" Then
.Cells(zeIle, sCol + 1).Value = "OK"
Else
.Cells(zeIle, sCol + 1).Value = "nicht OK"
End If
Else
' Kein Hyperlink, also Zelle daneben leeren
.Cells(zeIle, sCol + 1).ClearContents
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Gruss, Jogy
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge