Daten einer Homepage importieren

[McFly148]

Hallo zusammen,

ich möchte Daten von einer Homepage importieren. Ziel ist es, dass am Ende alles weitestgehend automatisiert abläuft. Also im Idealfall nur den Link eingeben und die Daten kommen dann in eine Tabelle. Ich möchte die Rennergebnisse sammeln aber auch die Bodenbedingungen und Distanz.

https://www.deutscher-galopp.de/gr/rennt...id=1334010&d=20220417&s=R

Könnt ihr mir mit einem Lösungsansatz helfen?

[Ralf A]

Hi,

das geht mit Power Query. Menü Daten --> Daten abrufen --> Aus anderen Quellen --> aus dem Web

Im sich öffnenden Navigator wählst Du Table 0 aus und klickst auf Daten transformieren. Hier kannst Du mit den Daten herumspielen.

[ws-53]

Da wirst du wohl schlechte Karten haben!

Zwar lässt sich die angegebene Seite ohne Probleme importieren, aber jede Seite hat eine ID, die intern vergeben wird und daran anschliessend das Tagedatum "id=1334010&d=20220418.

Dagegen haben die meisten auslesbaren Webadressen als id ID eine fortlaufende Seitennummer (page=1, page=2, ...) oder z.B. eine Kombination aus Datum und Seitennummer.

Hier aber müsstest du dir vorher, manuell, die IDs aller Seiten ermitteln, die du dann anschliessend mit Power Query auslesen könntest.

[Zwenn]

Hallo zusammen,

ich würde die Links für die Rennen erstmal hier abholen: https://www.deutscher-galopp.de/gr/renntage/ergebnisse/

Mappe mit entsprechender Tabelle habe ich angehängt. Für xlsm Phobiker hier der Code (Es werden keine Fehler abgefangen, wenn die Daten nicht so geliefert werden, wie erwartet):

Code:

Sub PferdeRennenUebersicht()

  Const urlErg As String = "https://www.deutscher-galopp.de/gr/renntage/ergebnisse/"
  Dim doc As Object
  Dim ort As Variant
  Dim rennen As Variant
  Dim datumOrt As String
  Dim preisgeld As String
  Dim distanz As String
  Dim url As String
  Dim currRow As Long
 
  currRow = 2
  Set doc = CreateObject("htmlFile")
 
  With CreateObject("MSXML2.XMLHTTP.6.0")
    .Open "GET", urlErg, False
    .Send
   
    If .Status = 200 Then
      doc.body.innerHTML = .responsetext
      Application.ScreenUpdating = False
     
      For Each ort In doc.getElementsByClassName("accordionContentHidden")
          datumOrt = Trim(ort.PreviousSibling.innertext)
        For Each rennen In ort.getElementsByClassName("accordionElementOuter")
          Cells(currRow, 1).NumberFormat = "dd.mm.yyyy"
          Cells(currRow, 1) = CDate(Left(datumOrt, 8))
          Cells(currRow, 2) = Right(datumOrt, Len(datumOrt) - 9)
          Cells(currRow, 3) = Trim(rennen.getElementsByClassName("accordionRennNrInner")(0).innertext)
          Cells(currRow, 4) = Trim(rennen.getElementsByClassName("accordionTitel")(0).innertext)
          preisgeld = Trim(rennen.getElementsByClassName("labelPreisgeld")(0).innertext)
          preisgeld = Replace(preisgeld, ".", "")
          preisgeld = Replace(preisgeld, " €", "")
          Cells(currRow, 5).NumberFormat = "#,##0 €"
          Cells(currRow, 5) = CLng(preisgeld)
          distanz = Trim(rennen.getElementsByClassName("labelDistanz")(0).innertext)
          distanz = Replace(distanz, ".", "")
          distanz = Replace(distanz, " m", "")
          Cells(currRow, 6).NumberFormat = "#,##0 ""m"""
          Cells(currRow, 6) = CLng(distanz)
          Cells(currRow, 7) = Trim(rennen.getElementsByClassName("label labelKategorie")(0).innertext)
          url = Replace(Trim(rennen.getElementsByTagName("a")(0).href), "about:", "https://www.deutscher-galopp.de")
          ActiveSheet.Hyperlinks.Add Anchor:=Cells(currRow, 8), Address:=url, TextToDisplay:=url
          currRow = currRow + 1
        Next rennen
      Next ort
     
      Application.ScreenUpdating = True
    Else
      MsgBox "Seite nicht geladen. HTTP-Status " & .Status
    End If
  End With
End Sub

Viele Grüße,

Zwenn

[Zwenn]

So,

ich habe mir das nochmal genauer angesehen.

Das erste Makro, zum holen der Übersicht, habe ich um die feste Tabellenzuweisung ergänzt. Die Tabelle mit der Übersicht habe ich mit zwei Buttons versehen. Wird die Übersicht neu geladen, werden bestehende Einträge in der Tabelle stumpf überschrieben. Man könnte vorher alle löschen oder nur die zufügen, die neu sind. Hatte ich jetzt aber keinen Nerv mehr drauf.

Dann habe ich eine zweite Tabelle zugefügt, in die die gewünschten Infos geschrieben werden. Es werden Details zu allen Rennen geholt, die in der Übersicht über den Autofilter ausgewählt wurden. Dafür ist der zweite Button da. Werden weitere Ergebnisse geholt, werden sie in der Ergebnistabelle immer unter die schon bestehenden geschrieben. Dabei wird nicht auf doppelte geprüft.

Das Auslesen aller Rennen dauert keine 10 Minuten. Ich habe die Mappe wieder angehängt und poste noch beide Makros so.

Makro zum holen der Übersicht für alle verfügbaren Pferderennen:

Code:

Sub PferdeRennenUebersicht()

  Const urlErg As String = "https://www.deutscher-galopp.de/gr/renntage/ergebnisse/"
  Dim doc As Object
  Dim ort As Variant
  Dim rennen As Variant
  Dim datumOrt As String
  Dim preisgeld As String
  Dim distanz As String
  Dim url As String
  Dim wsUeb As Worksheet
  Dim currRow As Long
 
  Set wsUeb = ThisWorkbook.Sheets("Pferderennen Übersicht")
  currRow = 3
  Set doc = CreateObject("htmlFile")
 
  With CreateObject("MSXML2.XMLHTTP.6.0")
    .Open "GET", urlErg, False
    .Send
   
    If .Status = 200 Then
      doc.body.innerHTML = .responsetext
      Application.ScreenUpdating = False
     
      For Each ort In doc.getElementsByClassName("accordionContentHidden")
          datumOrt = Trim(ort.PreviousSibling.innertext)
        For Each rennen In ort.getElementsByClassName("accordionElementOuter")
          With wsUeb
            .Cells(currRow, 1).NumberFormat = "dd.mm.yyyy"
            .Cells(currRow, 1) = CDate(Left(datumOrt, 8))
            .Cells(currRow, 2) = Right(datumOrt, Len(datumOrt) - 9)
            .Cells(currRow, 3) = Trim(rennen.getElementsByClassName("accordionRennNrInner")(0).innertext)
            .Cells(currRow, 4) = Trim(rennen.getElementsByClassName("accordionTitel")(0).innertext)
            preisgeld = Trim(rennen.getElementsByClassName("labelPreisgeld")(0).innertext)
            preisgeld = Replace(preisgeld, ".", "")
            preisgeld = Replace(preisgeld, " €", "")
            .Cells(currRow, 5).NumberFormat = "#,##0 €"
            .Cells(currRow, 5) = CLng(preisgeld)
            distanz = Trim(rennen.getElementsByClassName("labelDistanz")(0).innertext)
            distanz = Replace(distanz, ".", "")
            distanz = Replace(distanz, " m", "")
            .Cells(currRow, 6).NumberFormat = "#,##0 ""m"""
            .Cells(currRow, 6) = CLng(distanz)
            .Cells(currRow, 7) = Trim(rennen.getElementsByClassName("label labelKategorie")(0).innertext)
            url = Replace(Trim(rennen.getElementsByTagName("a")(0).href), "about:", "https://www.deutscher-galopp.de")
            ActiveSheet.Hyperlinks.Add Anchor:=.Cells(currRow, 8), Address:=url, TextToDisplay:=url
            currRow = currRow + 1
          End With
        Next rennen
      Next ort
     
      Application.ScreenUpdating = True
    Else
      MsgBox "Seite nicht geladen. HTTP-Status " & .Status
    End If
  End With
End Sub

Makro zum holen der Details zu Rennen, die über den Autofilter in der Übersicht ausgewählt wurden:

Code:

Sub PferdeRennenErgebnisse()

  Dim url As String
  Dim doc As Object
  Dim wsUeb As Worksheet
  Dim wsErg As Worksheet
  Dim letzteZeileUeb As Long
  Dim letzteZeileErg As Long
  Dim zeileErg As Long
  Dim gefiltert As Range
  Dim zeileGefiltert As Range
  Dim uhrzeit As String
  Dim boden As String
  Dim gewinn As String
  Dim bodenKnoten As Object
  Dim ergebnisContainerKnoten As Object
  Dim alleZeilenKnoten As Object
  Dim eineZeileKnoten As Object
  Dim alleZellenKnoten As Object
 
  Set wsUeb = ThisWorkbook.Sheets("Pferderennen Übersicht")
  letzteZeileUeb = wsUeb.Cells(Rows.Count, 1).End(xlUp).Row
  Set wsErg = ThisWorkbook.Sheets("Rennergebnisse")
  letzteZeileErg = wsErg.Cells(Rows.Count, 1).End(xlUp).Row
  zeileErg = letzteZeileErg + 1
  Set gefiltert = wsUeb.Range("A3:A" & letzteZeileUeb).SpecialCells(xlCellTypeVisible)
  Set doc = CreateObject("htmlFile")
 
  With CreateObject("MSXML2.XMLHTTP.6.0")
    For Each zeileGefiltert In gefiltert
      url = wsUeb.Cells(zeileGefiltert.Row, 8)
      .Open "GET", url, False
      .Send

      If .Status = 200 Then
        doc.body.innerHTML = .responsetext
        Application.ScreenUpdating = False
       
        uhrzeit = Right(Trim(doc.getElementsByClassName("startzeit")(0).innertext), 5)
        Set bodenKnoten = doc.getElementsByClassName("container-racefacts")(0).getElementsByTagName("span")
        If bodenKnoten.Length = 4 Then
          boden = Trim(bodenKnoten(3).innertext)
          boden = Replace(boden, "Boden:", "")
        Else
          boden = "k.A."
        End If
       
        Set ergebnisContainerKnoten = doc.getElementByID("ergebnis").getElementsByTagName("tbody")(0)
        Set alleZeilenKnoten = ergebnisContainerKnoten.getElementsByTagName("tr")
        For Each eineZeileKnoten In alleZeilenKnoten
          wsErg.Cells(zeileErg, 1).NumberFormat = "dd.mm.yyyy"
          wsErg.Cells(zeileErg, 1) = wsUeb.Cells(zeileGefiltert.Row, 1) 'Datum
          wsErg.Cells(zeileErg, 2).NumberFormat = "hh:mm"
          wsErg.Cells(zeileErg, 2) = CDate(uhrzeit) 'Uhrzeit
          wsErg.Cells(zeileErg, 3) = wsUeb.Cells(zeileGefiltert.Row, 2) 'Ort
          wsErg.Cells(zeileErg, 4) = wsUeb.Cells(zeileGefiltert.Row, 3) 'Rennen Nummer
          wsErg.Cells(zeileErg, 5) = boden 'Boden
         
          Set alleZellenKnoten = eineZeileKnoten.getElementsByTagName("td")
          wsErg.Cells(zeileErg, 6) = Trim(alleZellenKnoten(0).innertext) 'Platz
          wsErg.Cells(zeileErg, 7) = Trim(alleZellenKnoten(1).getElementsByTagName("a")(0).innertext) 'Name
          wsErg.Cells(zeileErg, 8) = Trim(alleZellenKnoten(2).innertext) 'Nummer
          wsErg.Cells(zeileErg, 9) = Trim(alleZellenKnoten(3).innertext) 'Box
          wsErg.Cells(zeileErg, 10) = Trim(alleZellenKnoten(4).innertext) 'Abstand
          gewinn = Trim(alleZellenKnoten(5).innertext) 'Gewinn
          If gewinn <> "" Then
            gewinn = Replace(gewinn, ".", "")
            gewinn = Replace(gewinn, " €", "")
            wsErg.Cells(zeileErg, 11).NumberFormat = "#,##0 €"
            wsErg.Cells(zeileErg, 11) = CLng(gewinn)
          End If
          wsErg.Cells(zeileErg, 12) = Trim(alleZellenKnoten(6).innertext) 'Besitzer
          wsErg.Cells(zeileErg, 13) = Trim(alleZellenKnoten(7).innertext) 'Trainer
          wsErg.Cells(zeileErg, 14) = Trim(alleZellenKnoten(8).innertext) 'Reiter
          wsErg.Cells(zeileErg, 15).NumberFormat = "0.0 ""kg"""
          wsErg.Cells(zeileErg, 15) = CDbl(Left(Trim(alleZellenKnoten(9).innertext), 4)) 'Gewicht
          zeileErg = zeileErg + 1
        Next eineZeileKnoten
       
        Application.ScreenUpdating = True
      Else
        wsUeb.Cells(zeileGefiltert.Row, 5) = "Seite nicht geladen. HTTP-Status " & .Status
      End If
    Next zeileGefiltert
  End With
End Sub

Viele Grüße,

Zwenn

[Zwenn]

Nocheinmal, weil es so schön ist

Wie es so ist beim Web Scraping, nicht alle möglichen Probleme treten zu jeder (Uhr)Zeit auf. Rennen für den aktuellen Tag werden in der Ergbnisübersicht bereits verlinkt. Aber da auch ein Makro nicht in die Zukunft gucken kann, stehen auf den aufgerufenen Seiten nicht die Daten, die wir wollen und deshalb gibt es Laufzeitfehler.

Ich habe das gefixt. Für laufende Rennen oder Rennen in der Zukunft, trage ich jetzt die "Grunddaten" inklusive Startzeit in die Ergebnistabelle ein und zusätzlich in Spalte 7 "Noch nicht beendet". Im Anhang ist die aktualisierte Mappe. Das Runterladen der (heute verfügbaren) 384 Rennergebnisse in der Übersicht hat ziemlich genau 5 Minuten gedauert. Das ergibt 3.326 Zeilen in der Ergebnistabelle und funktioniert somit recht schnell. Bei gesetztem Autofilter geht der Zeitbedarf abhängig von der Anzahl gewählter Rennen natürlich runter.

Achso, weil ich es gestern Nacht vergessen habe zu erwähnen. Zusatzinfos wie Scheuklappen und weitere Gewichtsaufschlüsselungen werden alle weggeschnitten und landen nicht in der Tabelle.

Viele Grüße,

Zwenn