Clever-Excel-Forum

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?

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.

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.

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

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

Nocheinmal, weil es so schön ist Wink

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

McFly148

Ralf A

ws-53

Zwenn

Zwenn

Zwenn