Internetseite aufrufen, aktualisieren, koppieren, einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub GetTankstellenPreise()

Const url As String = "https://www.tankstellenpreise.de/benzinpreise-bad-schoenborn.html"
Dim doc As Object
Dim nodeAllTs As Object
Dim oneTs As Long
Dim currRow As Long

Set doc = CreateObject("htmlFile")
currRow = 2

With CreateObject("MSXML2.XMLHTTP.6.0")
.Open "GET", url, False
.send

If .Status = 200 Then
doc.body.innerHTML = .responseText
Set nodeAllTs = doc.getElementsByClassName("ts")

For oneTs = 1 To nodeAllTs.Length() - 1
ActiveSheet.Cells(currRow, 1) = nodeAllTs(oneTs).getElementsByClassName("tankstelle")(0).innertext
ActiveSheet.Cells(currRow, 2) = nodeAllTs(oneTs).getElementsByClassName("preis")(0).innertext
currRow = currRow + 1
Next oneTs
Else
MsgBox "Page not loaded. HTTP status " & .Status
End If
End With
End Sub

Sub GetTankstellenPreise()

Const url As String = "https://www.tankstellenpreise.de/benzinpreise-bad-schoenborn.html"
Dim doc As Object
Dim nodeAllTs As Object
Dim nodeAllInnerDivs As Object
Dim nodeOnelInnerDiv As Object
Dim oneTs As Long
Dim currRow As Long

Set doc = CreateObject("htmlFile")
currRow = 2

With CreateObject("MSXML2.XMLHTTP.6.0")
.Open "GET", url, False
.send

If .Status = 200 Then
doc.body.innerHTML = .responseText
Set nodeAllTs = doc.getElementsByTagName("div")

For oneTs = 1 To nodeAllTs.Length() - 1
If nodeAllTs(oneTs).getAttribute("class") = "ts" Then
Set nodeAllInnerDivs = doc.getElementsByTagName("div")
For Each nodeOnelInnerDiv In nodeAllInnerDivs
If nodeOnelInnerDiv.getAttribute("class") = "tankstelle" Then
ActiveSheet.Cells(currRow, 1) = nodeOnelInnerDiv.innertext
End If
If nodeOnelInnerDiv.getAttribute("class") = "preis" Then
ActiveSheet.Cells(currRow, 2) = nodeOnelInnerDiv.innertext
currRow = currRow + 1
End If
Next nodeOnelInnerDiv
End If
Next oneTs
Else
MsgBox "Page not loaded. HTTP status " & .Status
End If
End With
End Sub

Hallo Aton,

Ralf hat Dir ehrlich gesagt sehr gute Infos gegeben. Mir ist klar, Du suchst eine Lösung. Aber bitte behalte immer im Auge, wir sind hier keine Dienstleister. Es geht in Foren wie diesem im Kern um Hilfe zur Selbsthilfe.

Da ich noch einen älteren Rechner rumstehen habe, auf dem genau Deine Software Konstellation mit Win 10 Pro und Excel 2010 installiert ist, habe ich den mal wieder eingeschaltet. Nach einer Menge Updates für's System und sonstiger Software, habe ich verschiedene Dinge ausprobiert. Alles, was mit dem Zugriff auf die verwendeten CSS Klassen von HTML-Tags zu tun hat, funktioniert unter Excel 2010 nicht mit xhr. Ein Satz, von dem Du vermutlich kein Wort verstehst. Egal, denn ich habe zähneknirschend eine Internet Explorer Lösung geschrieben, die genau das in die Tabelle schreibt, was ich mit meinem ersten Makro ohne Browser zeigen wollte. Du bist gut beraten, ein moderneres Excel zu verwenden.

In den Spalten A und B stehen grob verteilt Infos zu Tankstellen, Adressen, Spritsoten, Preisen und Zeitstemplen, von wann die Preise sind. Wie bereits erwähnt, kann das alles direkt feiner aufgeteilt in einzelne Spalten geschrieben werden. Die eigentliche Frage ist jetzt, was genau davon brauchst Du und wo genau? Also in welchen Spalten?

Heute verwende ich sogar wieder die richtige Code Formatierung ;-)



Sub GetTankstellenPreiseIE()

  Const url = "https://www.tankstellenpreise.de/benzinpreise-bad-schoenborn.html"

  Dim nodeAllTs As Object

  Dim nodeAllInnerDivs As Object

  Dim nodeOnelInnerDiv As Object

  Dim nodeTest As Object

  Dim oneTs As Long

  Dim currRow As Long

  

  currRow = 2

  

  With CreateObject("InternetExplorer.Application")

    .Visible = True 'Um den IE nicht anzuzeigen, auf False setzen

    .navigate url

    While .readyState > 4: DoEvents: Wend

    'Cookie annehmen wenn angezeigt

    '

    On Error Resume Next

    .document.getElementByID("c-p-bn").Click

    On Error GoTo 0

    

    Set nodeAllTs = .document.getElementsByClassName("ts")

    For oneTs = 1 To nodeAllTs.Length() - 1

      Set nodeTest = nodeAllTs(oneTs).getElementsByClassName("tankstelle")

      ActiveSheet.Cells(currRow, 1) = nodeAllTs(oneTs).getElementsByClassName("tankstelle")(0).innertext

      ActiveSheet.Cells(currRow, 2) = nodeAllTs(oneTs).getElementsByClassName("preis")(0).innertext

      currRow = currRow + 1

    Next oneTs

    .Quit

  End With

End Sub

Viele Grüße,

Zwenn

Hallo
Das unten sehende Makro geht bis zum ende durch.
in Cells(1, 6) steht dann die zahl 263.
so weit so gut, aber keine daten in spalte a und b, das nütz mir also gar nichts.

mit einzelschritten habe ich festgestellt daß das innere der 3 if then abfragen nicht bearbeitet werden.
deshalb keine daten als ergebnis

If nodeAllTs(oneTs).getAttribute("class") = "ts" Then was bedeutet "ts"
nodeAllTs in der Excelhilfe keinen Eintrag

If nodeOnelInnerDiv.getAttribute("class") = "Tankstellenpreise" Then
nodeOnelInnerDiv.getAttribute in der Excelhilfe keinen Eintrag

Kann es sein daß ich da etwas in Excel nachladen und installieren muss,
damit diese if then abfragen funktionieren.

Habe Excel 10 und Windows 10 Pro

Gruß Aton

PS. Bei der Webadresse war ich blind, da das makro diese zeile nicht ansprang.

Sub GetTankstellenPreise()
Const url As String = "https://www.tankstellenpreise.de/benzinpreise-bad-schoenborn.html"
Dim doc As Object
Dim nodeAllTs As Object
Dim nodeAllInnerDivs As Object
Dim nodeOnelInnerDiv As Object
Dim oneTs As Long
Dim currRow As Long
Set doc = CreateObject("htmlFile")
currRow = 2
With CreateObject("MSXML2.XMLHTTP.6.0")
.Open "GET", url, False
.send
If .Status = 200 Then
doc.body.innerHTML = .responseText
Set nodeAllTs = doc.getElementsByTagName("div")
For oneTs = 1 To nodeAllTs.Length() - 1
If nodeAllTs(oneTs).getAttribute("class") = "ts" Then
Set nodeAllInnerDivs = doc.getElementsByTagName("div")
For Each nodeOnelInnerDiv In nodeAllInnerDivs
If nodeOnelInnerDiv.getAttribute("class") = "Tankstellenpreise" Then
ActiveSheet.Cells(currRow, 1) = nodeOnelInnerDiv.innertext
End If
If nodeOnelInnerDiv.getAttribute("class") = "preis" Then
ActiveSheet.Cells(currRow, 2) = nodeOnelInnerDiv.innertext
currRow = currRow + 1
End If
Next nodeOnelInnerDiv
End If
Next oneTs
Else
MsgBox "Page not loaded. HTTP status " & .Status
End If
End With
Cells(1, 6) = oneTs
End Sub

Option Explicit Sub GetTankstellenPreise() Const url As String = "https://www.tankstellenpreise.de/benzinpreise-bad-schoenborn.html" Dim doc As Object Dim nodeAllTs As Object Dim nodeAllInnerDivs As Object Dim nodeOnelInnerDiv As Object Dim oneTs As Long Dim currRow As Long Dim splititems Set doc = CreateObject("htmlFile") currRow = 2 With CreateObject("MSXML2.XMLHTTP.6.0") .Open "GET", url, False .send If .Status = 200 Then doc.body.innerHTML = .responseText Set nodeAllTs = doc.getElementsByTagName("div") For oneTs = 1 To nodeAllTs.Length() - 1 If nodeAllTs(oneTs).getAttribute("class") = "ts" Then Set nodeAllInnerDivs = nodeAllTs(oneTs).getElementsByTagName("div") For Each nodeOnelInnerDiv In nodeAllInnerDivs If nodeOnelInnerDiv.getAttribute("class") = "tankstelle" Then splititems = Split(Replace(nodeOnelInnerDiv.innertext, vbCrLf & vbCrLf, vbCrLf), vbCrLf) ActiveSheet.Cells(currRow, 1) = splititems(0) ActiveSheet.Cells(currRow, 2) = splititems(1) & vbLf & splititems(2) End If If nodeOnelInnerDiv.getAttribute("class") = "preis" Then ActiveSheet.Cells(currRow, 3) = Replace(Replace(nodeOnelInnerDiv.innertext, vbCrLf & vbCrLf & vbCrLf, vbLf), vbCrLf, "") currRow = currRow + 1 End If Next nodeOnelInnerDiv End If Next oneTs Else MsgBox "Page not loaded. HTTP status " & .Status End If End With Cells(1, 6) = oneTs End Sub

Beliebteste Forumthreads (12 Monate)

Internetseite aufrufen, aktualisieren, koppieren, einfügen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Internetseite aufrufen, aktualisieren, koppieren, einfügen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread