Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 21:13:13
Kalenderwochen addieren
25.04.2024 21:06:05
Duplikate entfernen
25.04.2024 18:41:19
vba Zeilen duplizieren ab aktiver Zeile bis letzte Zeile
25.04.2024 18:22:55
Zeilen mit bestimmtem Datum in andere Mappe übertragen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1584to1588
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1584to1588
1584to1588
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Überprüfung einer Liste von www. auf Erreichbarkei

Überprüfung einer Liste von www. auf Erreichbarkei
25.10.2017 18:32:44
www.
Hallo Forum,
ich habe Excel-Spalte mit 1500 Web-Adressen, die ich gerne auf Erreichbarkeit testen würde.
Wenn eine Seite erfolgreich angepingt wurde, dann soll in die Nachbarzelle ein OK reingeschrieben werden.
Wie lässt sich das anstellen?
Besten Dank für Eure Rückmeldung.
HG STephan

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Archiv
25.10.2017 18:43:33
Fennek
Hallo,
vor langer Zeit war dies mein erster Versuch für diese Art von Aufgabe. Schau mal, ob dir das hilft.

Sub Webseite_pruefen()
Dim Hy As Hyperlink
With CreateObject("MSXML2.XMLHTTP")
For Each Hy In ActiveSheet.Hyperlinks
On Error Resume Next
'Debug.Print Hy.Address, Hy.Range.Address
.Open "get", Hy.Address, False
.send
If Err.Number  0 Then Range(Hy.Range.Address).Offset(0, 1) = Err.Number & ", " & Err. _
Description
'Do While .readystate  4
DoEvents
'  Debug.Print .Status
'Loop
Debug.Print .Status
On Error GoTo 0
Next Hy
End With
End Sub
mfg
Anzeige
AW: Archiv
25.10.2017 19:33:11
Karl
Hallo Fennek,
danke für Deine Info.
Leider tut sich bei mir gar nichts.
Vielleicht kann mir jemand den Code indie beigefügte Tabelle einbauen?
Das wäre super ;)
Beste Grüße
STephan
Beigefügt? Wo denn? Mann-o-mann! owT
25.10.2017 19:54:45
Luc:-?
:-?
Die Erreichbarkeit von Internetseiten...
26.10.2017 07:57:18
Internetseiten...
Hallo, :-)
... kannst Du so prüfen: ;-)
InternetCheckConnection...
Es ist ein Unterschied, ob Du einen Server im Netz anpingen, oder die Erreichbarkeit bestimmter Seiten prüfen möchtest.
Der Server "78.46.89.237" ist per Ping erreichbar. Die entsprechende Adresse "www.docandlaw.de" nicht. Der bremst das auch aus. ;-)
Eventuell musst Du noch ein paar Bremsen lösen (EnableEvents, Calculation, DisplayAlerts...).
Servus
Case
Anzeige
AW: Die Erreichbarkeit von Internetseiten...
26.10.2017 10:26:46
Internetseiten...
Hallo Case,
danke für Deine Untersüttzun, sieht schon mal ganz gut aus.
Probiere es am Wochenende aus und melde mich.
Beste Grüße
Stephan
Du musst das Thema...
26.10.2017 10:33:19
Case
Hallo Stephan, :-)
... nicht auf "offen" stellen - das kannst Du machen, wenn es nach dem Test Probleme gibt. ;-)
Servus
Case
AW: Die Erreichbarkeit von Internetseiten...
28.10.2017 16:56:20
Internetseiten...
Hallo Case,
danke nochmal für die Beispieldatei.
Es hat funktioniert.
Noch eine Frage:
Was muss ich verändern, wenn meine Webseiten in Spalte 17 und die Ausgabe ok/NE in Spalte 18 erfolgen soll?
Gibt es eigenlich in diesem Zusammenhang auch einen ähnlich funktionierenden eMail-Check?
Besten Dank um Voraus!
HG Stephan
Anzeige
Dann...
01.11.2017 13:03:04
Case
Hallo, :-)
so: ;-)
Option Explicit
Private Declare Function InternetCheckConnection Lib "wininet.dll" _
Alias "InternetCheckConnectionA" _
(ByVal url As String, _
ByVal dwFlags As Long, _
ByVal dwReserved As Long) As Long
Public Sub Main()
Dim lngLastRow As Long
On Error GoTo Fin
With Tabelle1
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 17)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
For lngLastRow = 2 To lngLastRow
If InternetCheckConnection(Trim(.Cells(lngLastRow, 1).Text), 1, 0) = 1 Then
.Cells(lngLastRow, 18).Value = "OK"
Else
.Cells(lngLastRow, 18).Value = "NE"
End If
Next lngLastRow
End With
Fin:
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Servus
Case
Anzeige
AW: Dann...
01.11.2017 14:15:17
Karl
Danke schöööön ;)
Prüfen auf gültige URL via HTTP-Status
26.10.2017 10:52:36
Zwenn
Hallo Karl,
Du kannst den HTTP-Status prüfen. Anton hat 2009 mal die folgende Funktion dazu hier im Forum veröffentlicht: 

Function URLExist(chkUrl As String) As Boolean
On Error Resume Next
Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
objXMLHTTP.Open "GET", chkUrl, False
objXMLHTTP.send
If objXMLHTTP.Status = 200 Then
URLExist = True
Else
URLExist = False
End If
Set objXMLHTTP = Nothing
End Function

Quelle: https://www.herber.de/forum/archiv/1084to1088/1084301_Per_VBA_Erreichbarkeit_von_Hyperlinks_ueberpruefen.html#1084413
Viele Grüße,
Zwenn
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige