AW: Daten aus Internetseite in Excel
10.07.2018 13:09:49
Zwenn
Hallo zusammen,
wie immer gibt es mehrere Lösungen, ist ja auch gut so :-) Bei Dir Chris, fehlt allerdings die Mengenangabe und auch die Links sind nicht vollständig. Man kann die direkt inklusive Domain auslesen.
Beim Ausprobieren ist mir etwas aufgefallen, was ich auch in den Kommentaren des Makros nochmal genant habe. Aber weil es so wichtig ist, weise ich hier nochmal ganz explizit darauf hin:
Achtung: Um wirklich auf die Angebotsseite des richtigen Marketes zu kommen, muss man im Internet Explorer einmal die gewünschte Stadt Als "Mein Markt" markieren. Macht man das nicht, wird immer die Angebotsseite vom Markt in Siegburg ausgelesen!
Fürs Auslesen lasse ich den IE mal sichtbar und am Ende auch geöffnet. So hat man eine direkte Sichtkontrolle, ob wirklich die Seite zum richtigen Markt (in der richtigen Stadt) geöffnet wurde. Die Angebote unterscheiden sich teilweise. Das habe ich kontrolliert.
Alles ins gleiche Modul:
Option Explicit
Sub HitAngeboteHolen()
Dim browser As Object
Dim url As String
Dim knoten As Object
Dim knotenStamm As Object
Dim knotenAst As Object
Dim knotenZweig As Object
Dim zielTabelle As String
Dim zeileZielTabelle As Long
Dim spalteZielTabelle As Byte
Dim angebotsText As String
Dim angebotsBeschreibung As String
Dim angebotsPreis As String
Dim angebotsMenge As String
'Tabelle für die Ausgabe der ausgelesenen Daten
zielTabelle = "Tabelle4"
'Zeile und Spalte für die Ausgabe initialisieren
zeileZielTabelle = 2
spalteZielTabelle = 1
'Adresse der Angebotsseite
'Achtung: Um wirklich auf die Angebotsseite des richtigen Marketes zu kommen,
'muss man im Internet Explorer einmal die gewünschte Stadt als "Mein Markt" markieren
'Macht man das nicht, wird immer die Angebotsseite vom Markt in Siegburg ausgelesen!
url = "https://www.hit.de/angebote-leipzig/alle-angebote.html"
'Internet Explorer initialisieren, Sichtbarkeit festlegen,
'Seite im IE aufrufen und warten bis sie vollständig geladen ist
Set browser = CreateObject("internetexplorer.application")
browser.Visible = True
browser.Navigate url
Do Until browser.readyState = 4: DoEvents: Loop
'Artikel-Boxen aus dem Quellcode der Seite in ein Array separieren
Set knoten = browser.document.getElementsByTagName("article")
'Wenn Artikel vorhanden, dann einen nach dem anderen in die Tabelle schreiben
If Not knoten Is Nothing Then
'Alle Angebote durchgehen
For Each knotenStamm In knoten
'Angebotstitel holen
Set knotenAst = knotenStamm.getElementsByTagName("h4")(0)
'Titel in die Tabelle schreiben, wenn der erste Tag
'h4 im aktuell bearbeiteten Angebot gefunden wurde
If Not knotenAst Is Nothing Then
Sheets(zielTabelle).Cells(zeileZielTabelle, spalteZielTabelle).Value = _
knotenAst.innertext
End If
'Ausgabespalte für die Mengenangabe setzen
spalteZielTabelle = spalteZielTabelle + 1
'Menganangabe holen
'Die Mengenangabe steht innerhalb des ersten p-Tags in einer article-Box
'darin enthalten ist ein span-Tag mit Zusatzinformationen und
'manchmal ein small-Tag mit Preisangabe pro Mengeneinheit.
'Es gibt verschiedene Wege, um an die gewünschte Mengenangabe zu kommen
'Hier nehmen wir den innertext des p-Tag, des span-Tag und des small-Tag
'Da im p-Tag sowohl das span- wie small-Tag enthalten sind, können wir den
'gewünschten Text bekommen, indem aus dem p-Tag-String (sofern vorhanden)
'den span-Tag-String und den small-Tag-String entfernen
Set knotenAst = knotenStamm.getElementsByTagName("p")(0)
'Wenn p-Tag vorhanden, Stringbearbeung vornehmen
If Not knotenAst Is Nothing Then
'Gesamten Text innerhalb des p-Tags übernehmen
'(enthält auch Text innenliegender Tags)
angebotsText = knotenAst.innertext
'Eventuell enthaltenen span-Tag aus p-Tag auslesen
Set knotenZweig = knotenAst.getElementsByTagName("span")(0)
'Wenn span-Tag in p-Tag vorhanden, Text übernehmen
If Not knotenZweig Is Nothing Then
angebotsBeschreibung = knotenZweig.innertext
End If
'Eventuell enthaltenen small-Tag aus p-Tag auslesen
Set knotenZweig = knotenAst.getElementsByTagName("small")(0)
'Wenn small-Tag in p-Tag vorhanden, Text übernehmen
If Not knotenZweig Is Nothing Then
angebotsPreis = knotenZweig.innertext
End If
'Textteile von span-Tag und small-Tag aus p-Tag-Text entfernen
angebotsMenge = Replace(angebotsText, angebotsBeschreibung, "")
angebotsMenge = Replace(angebotsMenge, angebotsPreis, "")
'Zeilenumbrüche (durch br-Tags) und überzählige Leerzeichen entfernen
angebotsMenge = KeineZeilenUmbrueche(angebotsMenge)
angebotsMenge = Replace(angebotsMenge, " ", " ")
'Mengenangabe ausgeben
Sheets(zielTabelle).Cells(zeileZielTabelle, spalteZielTabelle).Value = _
Trim(angebotsMenge)
End If
'Ausgabespalte für die Bilderlink setzen
spalteZielTabelle = spalteZielTabelle + 1
'Bilderlink auslesen
'Der Bilderlink kann im ersten oder zweiten img-Tag stehen
'Das richtige img-Tag liegt jedoch innerhalb eines div-Tags mit
'einer eigenen CSS-Klasse. So kommt man immer an den richtigen
'Bilderlink
Set knotenAst = knotenStamm.getElementsByClassName("wv_product text-center ")(0)
'Bilderlink aus erstem Tag mit gesuchter CSS-Klasse holen, wenn vorhanden
If Not knotenAst Is Nothing Then
Set knotenZweig = knotenAst.getElementsByTagName("img")(0)
If Not knotenZweig Is Nothing Then
Sheets(zielTabelle).Cells(zeileZielTabelle, spalteZielTabelle).Value = _
knotenZweig.src
End If
End If
'Ausgabezeile für nächstes Angebot setzen und
'Ausgabespalte für nächsten Angebotstitel setzen
zeileZielTabelle = zeileZielTabelle + 1
spalteZielTabelle = 1
'Nächstes Angebot bearbeiten
Next knotenStamm
Else
'Wenn kein Artikel vorhanden, einen Hinweis ausgeben
MsgBox "Es wurde kein Artikel gefunden"
End If
'Aufräumen
' browser.Quit
Set browser = Nothing
Set knoten = Nothing
Set knotenStamm = Nothing
Set knotenAst = Nothing
Set knotenZweig = Nothing
End Sub
Function KeineZeilenUmbrueche(zuSaeubern As String) As String
Dim vergleichVorAustausch As String
Dim vergleichNachAustausch As String
vergleichVorAustausch = zuSaeubern
Do
vergleichNachAustausch = vergleichVorAustausch
vergleichVorAustausch = Replace(vergleichVorAustausch, Chr(10), " ")
Loop Until vergleichNachAustausch = vergleichVorAustausch
Do
vergleichNachAustausch = vergleichVorAustausch
vergleichVorAustausch = Replace(vergleichVorAustausch, Chr(13), " ")
Loop Until vergleichNachAustausch = vergleichVorAustausch
KeineZeilenUmbrueche = vergleichVorAustausch
End Function
Schick machen musst Du Dir die Tabelle selbst ;-) Daten werden ab Zeile 2 eingetragen. Es wird nicht geprüft, ob Daten in der Tabelle stehen. Ggf. werden vorhandene also einfach überschrieben. Als Zieltabelle habe ich Deine 'Tabelle4' übernommen. Das kannst Du ggf. oben im Makro einfach ändern. Den String für die Mengenangaben habe ich soweit gesäubert, dass er ordentlich in der Tabelle landet.
Viele Grüße,
Zwenn