Automatische Datengewinnung aus dem Web – die HTTPRequest-Variante

In diesem Artikel zeige ich eine weitere Möglichkeit zur einfachen automatischen Datengewinnung aus dem Web. Diese Methode ist sehr schnell und eignet sich deshalb für die Verarbeitung vieler Abrufe.

In diesem Artikel hatte ich bereits eine andere Möglichkeit beschrieben:

Daten aus dem Web automatisch in ein Excel-Sheet übertragen – QueryTable-Variante

Ich bleibe in meinem heutigen Artikel beim Beispiel daraus, und zwar der KGV-Berechnung auf der Basis des 5-Jahres-EPS-Durchschnitts. Das gleiche Tabellenblatt „Zahlen“ mit den gleichen Formeln:

Vorher:

Excel-Tabelle Zahlen

Nachher:

Excel-Tabelle mit Daten

Und nun das „Dazwischen“. Das ist das Makro „Daten“, welches selbige aus dem Internet abruft und in die weißen Tabellenzellen füllt. So könnte es gestaltet werden:

Sub Daten()

    Dim shZ As Worksheet
    Dim zeile As Integer
    Dim url As String
    Dim doc As HTMLDocument
    Dim coll As IHTMLElementCollection
    Dim table As HTMLTable
    Dim jahre As HTMLTableRow, eps As HTMLTableRow
    Dim indexLJ As Integer
    Dim k As Integer
    Dim inhalt As String
    Dim ele As IHTMLElement
    Dim kurs As String, datum As String
    Dim V As Variant
    
    Const Z_SPALTE_DATUM = 3
    Const Z_SPALTE_KURS = 4
    Const Z_SPALTE_LJ = 5
    Const Z_SPALTE_EPS_LJ = 8
    
    Set shZ = Sheets("Zahlen")
    
    'Zeile für Zeile abarbeiten
    zeile = 2
    Do Until shZ.Cells(zeile, 1).Value = ""
        
        'Status-Zeilen-Anzeige
        Application.StatusBar = "Zeile " & zeile & _
        " - " & shZ.Cells(zeile, 1).Value
        DoEvents                'damit der Bildschirm aktualisiert wird
        
        'vorhandene Angaben entfernen
        For k = Z_SPALTE_DATUM To Z_SPALTE_EPS_LJ + 2
            shZ.Cells(zeile, k).Value = ""
        Next
        
        'Web-Abfrage durchführen
        url = "https://www.onvista.de/aktien/fundamental/" & _
        Replace(shZ.Cells(zeile, 1).Value, " ", "-") & _
        "-Aktie-" & shZ.Cells(zeile, 2).Value
        If LadeURL(url, doc) Then

            Set coll = doc.getElementsByTagName("h2")
            If coll.Length > 0 Then
                'Test, dass Kennzahlen-Seite geladen wurde
                If coll(0).innerText Like "Kennzahlen zu *" Then
                    Set coll = doc.getElementsByTagName("table")
                    If coll.Length > 1 Then
                        Set table = coll(1)  '2. Tabelle (Zählung ab 0)
                        If table.Rows.Length > 1 Then
                            Set jahre = table.Rows(0)   'erste Zeile
                            Set eps = table.Rows(1)     'zweite Zeile
                        End If
                    End If
                End If
            End If
            'letztes Geschäftsjahr ermitteln:
            indexLJ = 0
            For k = 1 To jahre.Cells.Length
                If Not (Trim(jahre.Cells(k).innerText) Like "*e") Then
                    indexLJ = k
                    Exit For
                End If
            Next
            'EPS-Daten übernehmen
            If indexLJ > 0 Then
                inhalt = Trim(jahre.Cells(indexLJ).innerText)
                If (inhalt Like "####") Or (inhalt Like "##/##") Then
                    shZ.Cells(zeile, Z_SPALTE_LJ).Value = inhalt
                    For k = 2 To -2 Step -1
                        If (indexLJ + k > 0) And _
                        (eps.Cells.Length >= indexLJ + k) Then
                            inhalt = Trim(eps.Cells(indexLJ + k).innerText)
                            'Zahlenformat passend machen und Zahl übernehmen
                            inhalt = Replace(inhalt, ".", "")
                            inhalt = Replace(inhalt, ",", _
                            Application.DecimalSeparator)
                            If IsNumeric(inhalt) Then
                                shZ.Cells(zeile, Z_SPALTE_EPS_LJ - k).Value = _
                                CDbl(inhalt)
                            End If
                        End If
                    Next
                End If
            End If
            
            Set coll = doc.getElementsByClassName("KURSDATEN")
            For Each ele In coll
                If ele.tagName = "UL" Then
                    Set coll = ele.getElementsByTagName("li")
                    If coll.Length > 0 Then
                        kurs = Trim(coll(0).innerText)
                        Set coll = doc.getElementsByTagName("cite")
                        If coll.Length > 0 Then
                            datum = Trim(coll(0).innerText)
                            'in kurs und datum stehen Inhalte
                        End If
                    End If
                    Exit For
                End If
            Next
            'Datumsteil extrahieren
            If datum Like "##.##.####, ##:##:##" Then
                V = Split(Left(datum, 10), ".")
                shZ.Cells(zeile, Z_SPALTE_DATUM).Value = _
                DateSerial(CInt(V(2)), CInt(V(1)), CInt(V(0)))
            End If
            'Kursangabe als Zahl, vorher Format passend machen
            V = Split(kurs, " ")   'die Angabe " EUR" entfernen
            kurs = V(0)
            kurs = Replace(kurs, ".", "")
            kurs = Replace(kurs, ",", Application.DecimalSeparator)
            If IsNumeric(kurs) Then
                shZ.Cells(zeile, Z_SPALTE_KURS).Value = CDbl(kurs)
            End If

        End If

        zeile = zeile + 1
    Loop                    'nächste Zeile!
    
    Application.StatusBar = "OK"
    
End Sub

Dazu wird natürlich noch die Function LadeURL gebraucht. Etwa so:

Function LadeURL(url As String, doc As HTMLDocument) As Boolean
    Dim request As New WinHttpRequest
    request.Open "GET", url, False
    request.setRequestHeader "User-Agent", "Mozilla/5.0"
    On Error Resume Next
    request.Send
    If Err.Number <> 0 Then
        Err.Clear
        Set doc = Nothing
        LadeURL = False
    Else
        Set doc = New HTMLDocument
        doc.body.innerHTML = request.ResponseText
        LadeURL = True
    End If
    On Error GoTo 0
    Set request = Nothing
End Function

Und damit das Ganze funktioniert, müssen im VBA-Editor im Menü Extras Verweise auf die Microsoft WinHTTP Services und die Mirosoft HTML Object Library gesetzt werden.

Und übrigens: Ein Hilfsblatt „Web“ wird für diese Variante nicht benötigt.