AW: Daten von Webseite abfragen
20.08.2016 12:35:50
Webseite
Hallo Dagi
Habe Dich vorher nicht ganz richtig verstanden und Dir daher vorher einen falschen Tipp gegeben. Versuchen wir es nochmals :-)
Ich habe Dir ein Excel-File mit dem Code von unten hochgeladen:
https://www.herber.de/bbs/user/107733.xlsm
Das ganze ist ziemlich langsam, daher teste es zuerst mit einer sehr kurzen Zeitdauer von wenigen Tagen.
Location (Flughafen) und Zeitperiode kannst Du im Excel-File eintragen.
Im Code musst Du allenfalls noch die Spaltenüberschriftten gemäss Deiner Spracheinstellung anpassen. (Ich habe leider die Spracheinstellung nicht gefunden.) Bei mir sind die Überschriften der Spalten auf Schweizerdeutsch. Wenn Du deutsche Überschriften hast, musst Du unten "Ziit (GTM)" warhscheinlich durch "Zeit (GTM)" ersetzen, "Temp" durch "Temp." und "Füechtigkeit" durch "Feuchtigkeit".
Ich hoffe, das hilft Dir weiter.
Liebe Grüsse
Miraamis
Option Explicit
Public Sub weatherHistory()
Dim wsHist As Worksheet
Dim colTime As Integer, colTemp As Integer, colFeuchtigkeit As Integer
Dim colMax As Integer, rowExcel As Long
Dim strHour As String, datumStart As Date, datumEnde As Date, datum As Date
Dim location As String
Dim antwortMsgBox As Integer
Dim objRegex As Object
Dim XMLHttpRequest As Object
Dim strURL As String
Dim HTMLBody As Object
Dim HTMLDoc As Object
Dim HTMLTable As Object
Dim HTMLTableHeader As Object
Dim tr As Object
Dim rowTableHeader As Integer
Set XMLHttpRequest = CreateObject("MSXML2.ServerXMLHTTP.6.0")
On Error GoTo fehler
Set wsHist = ActiveSheet
rowExcel = 2 'Erste Zeile in Excel, die ausgefüllt werden soll
'Statusbar
Dim oldStatusBar As Boolean
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Daten aus Weather Underground importieren...."
'Regular Expression um Zeit auszulesen (nur volle Stunden)
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "\d{1,2}:00\s((AM)|(PM))"
'Eingegebene Location
location = wsHist.Range("Location").Value
'Überprüfen, ob wirklich ein "Von" und "Bis" Datum eingegeben wurden
If IsDate(wsHist.Range("Von").Value) = False Or IsDate(wsHist.Range("Bis").Value) = False Then
MsgBox "Ungültige Datumseingabe.", vbInformation
Exit Sub
End If
'Eingegebene Daten (Von und Bis)
datumStart = wsHist.Range("Von").Value
datumEnde = wsHist.Range("Bis").Value
datum = datumStart
'Loop über jeden Tag in der gewünschten Zeitperiode
Do Until datum > datumEnde
'Statusbar, damit wir bei langen Abfragen, wissen wie viele Daten
'bereits heruntergeladen wurden
Application.StatusBar = "Daten vom " & Format(datum, "dd.mm.yy") & _
" aus Weather Underground importieren...."
'Url anpassen (angegebene location und datum einsetzen)
strURL = "https://www.wunderground.com/history/airport/" & _
location & "/" & Year(datum) & "/" & Month(datum) & "/" & Day(datum) & _
"/DailyHistory.html"
'Request
With XMLHttpRequest
.Open "GET", strURL, False
.SetRequestHeader "content-type", "text/html; charset=UTF-8"
.Send
End With
'Warten bis request beendet
While XMLHttpRequest.ReadyState 4
DoEvents
Wend
Set HTMLDoc = CreateObject("htmlfile")
Set HTMLBody = HTMLDoc.body
HTMLBody.innerHTML = XMLHttpRequest.responseText
'Die Tabelle, die uns interessiert heisst "obsTable"
Set HTMLTable = HTMLDoc.getElementById("obsTable")
'Leider sind die Tabellen nicht immer genau gleich aufgebaut.
'(Feuchtigkeit ist manchmal in Spalte 3 und manchmal in Spalte 4.
'Daher müssen wir zuerst die richtige Spalte finden.
'Ich konnte die Spracheinstellungen nicht finden, daher kann es sein,
'dass bei Dir die Überschriften anders lauten. Dann musst Du das anpassen
'Titel - Spalten von Temp. und Feuchtigkeit bestimmen
Set HTMLTableHeader = HTMLTable.getElementsByTagName("thead")
colTime = -1
colTemp = -1
colFeuchtigkeit = -1
If IsNull(HTMLTableHeader(0).getElementsByTagName("tr")(0)) = False Then
Set tr = HTMLTableHeader(0).getElementsByTagName("tr")(0)
'Loop über alle Spalten (erste Spalte hat nr. 0, zweite nr. 1, etc.)
For rowTableHeader = 0 To tr.getElementsByTagName("th").Length - 1
'************************ An Deine Spracheinstellungen anpassen ****************
'Allenfalls musst Du hier die Überschrift anpassen, daher "Ziit (GMT)" ersetzen
If tr.getElementsByTagName("th")(rowTableHeader).innerText = "Ziit (GMT)" Then
colTime = rowTableHeader
'Allenfalls musst Du hier die Überschrift anpassen, daher "Temp." ersetzen
ElseIf tr.getElementsByTagName("th")(rowTableHeader).innerText = "Temp" Then
colTemp = rowTableHeader
'Allenfalls musst Du hier die Überschrift anpassen, daher "Füechtigkeit" ersetzen
ElseIf tr.getElementsByTagName("th")(rowTableHeader).innerText = _
"Füechtigkeit" Then
colFeuchtigkeit = rowTableHeader
End If
If Application.WorksheetFunction.Min(colTime, colTemp, colFeuchtigkeit) >= 0 Then _
Exit For
Next
End If
Set tr = Nothing
'colTime entspricht der Spalte der Zeit in historischer Übersicht
'colTemp entspricht der Spalte der Temperatur in historischer Übersicht
'colFeuchtigkeit entspricht der Spalte der Feuchtigkeit in historischer Übersicht
colMax = Application.WorksheetFunction.Max(colTime, colTemp, colFeuchtigkeit)
'Meldung, falls eine Spalte nicht gefunden wurde
If Application.WorksheetFunction.Min(colTime, colTemp, colFeuchtigkeit) = -1 Then
antwortMsgBox = MsgBox("Eine der gesuchten Spalten wurde nicht gefunden. " & _
"Soll mit dem nächsten Tag " & _
"fortgefahren werden?", vbYesNo + vbCritical)
If antwortMsgBox = 6 Then
GoTo nextDay
Else
Exit Sub
End If
End If
'Daten von diesem Tag auslesen
'Loop über alle Zeilen
For Each tr In HTMLTable.getElementsByTagName("tr")
'Überprüfen, ob es genügend Spalten hat
If tr.getElementsByTagName("td").Length >= colMax Then
'Zeit auslesen
strHour = tr.getElementsByTagName("td")(colTime).innerText
'Überprüfen, ob es sich um eine volle Stunde handelt
If objRegex.test(strHour) = True Then
strHour = objRegex.Execute(strHour)(0)
'Datum & Zeit eintragen
wsHist.Cells(rowExcel, 1).Value = datum & " " & strHour 'Zeit
'Temperatur eintragen
wsHist.Cells(rowExcel, 2).Value = _
tr.getElementsByTagName("td")(colTemp).innerText
'Feuchtigkeit eintragen
wsHist.Cells(rowExcel, 3).Value = _
tr.getElementsByTagName("td")(colFeuchtigkeit).innerText
rowExcel = rowExcel + 1
End If
End If
Next
Set HTMLDoc = Nothing
Set HTMLBody = Nothing
Set HTMLTable = Nothing
'Nächste Tag
nextDay:
datum = datum + 1
Loop
'Statusbar wieder auf vorherigen Wert einstellen.
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
MsgBox "Daten wurden heruntergeladen.", vbInformation
Set objRegex = Nothing
Set wsHist = Nothing
Set HTMLDoc = Nothing
Set HTMLBody = Nothing
Set HTMLTable = Nothing
Exit Sub
fehler:
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
'Fehlermeldung
MsgBox "Es ist ein Fehler aufgetreten. " & vbCrLf & "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description, vbCritical
Set objRegex = Nothing
Set wsHist = Nothing
Set HTMLDoc = Nothing
Set HTMLBody = Nothing
Set HTMLTable = Nothing
End Sub
