Extract data from website in a loop (changing date) to Sheet - html

Question

First off, I'm completely new to VBA and want to build a weather statistic in Excel. Help is much appreciated!
For this I need data from multiple websites which include the information of the messured temperature, the weather station and the time.
With some VBA information I found on the internet I have so far written a code, which delivers me the needed information for one website in the immediate window only.
Which looks like this:
7.4°C | Wien-Mariabrunn (225m) | 14:00
7.6°C | Wien-Hohe Warte (198m) | 14:00
7.6°C | Wien-Unterlaa (200m) | 14:00
7.7°C | Wien-Schwechat (183m) | 14:00
7.8°C | Wien-Donaufeld (160m) | 14:00
8.1°C | Grossenzersdorf (154m) | 14:00
8.2°C | Wien-City (177m) | 14:00
Dim xmlReq As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
Dim Temps1 As MSHTML.IHTMLElementCollection
Dim temps2 As MSHTML.IHTMLElementCollection
Dim Temp As MSHTML.IHTMLElement
xmlReq.Open "GET", "https://kachelmannwetter.com/at/messwerte/wien/temperatur/20190101-1300z.html", False
xmlReq.send
If xmlReq.Status <> 200 Then
MsgBox "Problem" & vbNewLine & xmlReq.Status & " - " & xmlReq.statusText
Exit Sub
End If
HTMLDoc.body.innerHTML = xmlReq.responseText
Set Temps1 = HTMLDoc.getElementsByClassName("ap o o-1 o-tmp-5")
Set temps2 = HTMLDoc.getElementsByClassName("ap o o-1 o-tmp-1")
For Each Temp In Temps1
Debug.Print Temp.Title
Next Temp
For Each Temp In temps2
Debug.Print Temp.Title
Next Temp
First problem I have, is that I have no idea how to put this information into a sheet or cells.
The second problem is, that I need the same data from multiple websites from a startdate to enddate.
The website I used in this example-code is https://kachelmannwetter.com/at/messwerte/wien/temperatur/20190101-1300z.html. At the end you can find the date, in this example "20190101" & the time "1300".
So for this I need some kind of loop.
So at the end I need a worksheet with column A with the date, column B with the time and column C with the data (for each date & time).
I hope this was somehow understandable and I am very thankful for any help.

Answer 1

The following works nicely for short date ranges. Longer date ranges lead to slower response. It is likely website is blocking/throttling. To this end:
I include a variable pauseIndex which means that every x (=pauseIndex) number of urls, a delay of y seconds (as specified by waitSeconds) before the next request is added. You can play with this.
You might consider adapting code to run in daily/monthly batches and either append to bottom of existing dataset or write to a new sheet using the current day/month as title.
Perhaps rotate/change IPs and use MSXML2.ServerXMLHTTP.
Tinker with the above to get the optimal settings and batch request size (if doing batch).
Specifying start datetime and end datetimes:
The date ranges are specified in a sheet called Date ranges. It has the following set-up:
Building a dataset:
I would recommend building a flat table dataset where you specify the exact stations to return info for. Not each station appears for every timedate.
stations = Array("Wien-Schwechat", "Wien-Unterlaa", "Wien-Mariabrunn", "Wien-Hohe Warte", "Grossenzersdorf", _
"Wien-Donaufeld", "Wien-City")
You can expand this. I include a dictionary variable newStations which stores all stations encountered that are not in your list for monitoring. You can easily write these out to help decide on additional stations to monitor/include in your dataset.
Placeholder values for missing station readings are used to ensure a complete dataset.
You may wish to normalise “outliers” - for example, actual hour values can lie within the range rather than on the hour. In the demo below 16:20 is retrieved accurately for one station. You could normalise this to 16:00.
Helper functions/Sub:
There are a number of helper functions, and 1 sub, used in the code.
GetAllLinks. Generates all request urls between start date time and end date time. See notes within code. These can be looped to issue each request for data
EmptyDict - ensure that station data is cleared out between requests
UpdateDictForNoReading. Handles the case where a monitored station is not reported for specified datetime. It updates temperature and long station description with "No reading"
WriteOutResults. Produces a "flat" i.e. not nested, 2D array structure and writes results to specified output sheet
Retrieving stations and station data:
I use a css attribute = value selector, with contains operator, to target the station data.
Taking a example station's HTML
<a class="ap o o-1 o-tmp--1" data-target="#obs-detail-3h" data-toggle="modal" data-left="635" data-top="545" onclick="obs_detail_3h('-1.0°C', 'Wien-Schwechat (183m)', '16:20','110360', '201901031500');" title="-1.0°C | Wien-Schwechat (183m) | 16:20" style="left: 408.533px; top: 337.757px;">-1</a>
If we look at the class attribute we see that is it as follows:
class="ap o o-1 o-tmp--1"
The value of the class attribute is "ap o o-1 o-tmp--1", which is in fact a series of classes separated by spaces. Each station class value has the same substring which is o-tmp. You could vary this slightly. I use querySelectorAll to return a nodeList of all elements which have this substring in the class attribute value.
Set mapStations = html.querySelectorAll("[class*='o-tmp']")
This matches all stations on the page (map).
The title attribute of each node in the nodeList (mapStations) contains the data of interest:
title="-1.0°C | Wien-Schwechat (183m) | 16:20"
The string contains pipe (|) delimiters. I can use split() to generate an array containing each bit of info:
arr = Split(mapStations.item(i).Title, " | ")
That generates an array which will have -1.0°C , Wien-Schwechat (183m) and 16:20 at different indices. Using this example, I store -1.0°C in variable temp, Wien-Schwechat (183m) in variable stationFull, just the station name Wien-Schwechatin station, 16:20 in time.
TODO:
Refactor to reduce level of nesting
Error handling for cases such as status code <> 200.....
Move variable declarations closer to their usage
Requirements:
VBE > Tools > References > Add reference to Microsoft HTML Object Library
Worksheet called Date ranges
Worksheet called Output
Data in Date ranges should be laid out as shown in image above.
VBA:
Option Explicit
Public Sub GetInfo()
'VBE > Tools > References > Microsoft HTML Object Library
'Collect hourly temperature readings from list of stations in array stations.
'Missing readings are populated with "Missing reading". Times specified in request are not necessarily identical _
'to that correctly returned from page as reading reported within an hour interval may not be on the hour
Dim html As HTMLDocument, i As Long, arr() As String, mapStations As Object, dict As Object, newStations As Object
Dim time As String, station As String, temp As String, stations(), results(), j As Long
Dim urls As Object, url As Variant, startOfDateString As Long, currDate As String, stationFull As String
Dim outputSht As Worksheet, x As Long
Const pauseIndex As Long = 20
Const waitSeconds As Long = 1
Const PREFIX As String = "https://kachelmannwetter.com/at/messwerte/wien/temperatur/"
Const SUFFIX As String = "z.html"
startOfDateString = InStrRev(PREFIX, "/") + 1
Set outputSht = ThisWorkbook.Worksheets("Output")
Set urls = GetAllLinks(PREFIX, SUFFIX)
Set html = New HTMLDocument
Set dict = CreateObject("Scripting.Dictionary")
Set newStations = CreateObject("Scripting.Dictionary")
stations = Array("Wien-Schwechat", "Wien-Unterlaa", "Wien-Mariabrunn", "Wien-Hohe Warte", "Grossenzersdorf", _
"Wien-Donaufeld", "Wien-City") 'order of stations here should match that in sheet
j = 1
For i = LBound(stations) To UBound(stations)
dict(stations(i)) = vbNullString
Next
ReDim results(1 To 1 * urls.Count)
With CreateObject("MSXML2.XMLHTTP")
For Each url In urls
x = x + 1
If x Mod pauseIndex = 0 Then Application.Wait Now + TimeSerial(0, 0, waitSeconds)
DoEvents
.Open "GET", url, False
.setRequestHeader "User-Agent", "Mozilla/5.0"
.send
html.body.innerHTML = .responseText
Set mapStations = html.querySelectorAll("[class*='o-tmp']")
For i = 0 To mapStations.Length - 1
arr = Split(mapStations.item(i).Title, " | ")
currDate = Join(Array(Mid$(url, startOfDateString + 4, 2), Mid$(url, startOfDateString + 6, 2), Mid$(url, startOfDateString, 4)), "-")
temp = arr(0)
station = Split(arr(1), " (")(0)
stationFull = arr(1)
time = arr(2)
If Not dict.Exists(station) Then
newStations(station) = vbNullString 'in case you are interested in which stations exist you are not monitoring
Else
dict(station) = Array(currDate, time, station, stationFull, temp)
End If
Next
Set dict = UpdateDictForNoReading(dict, currDate, time)
results(j) = dict.items
j = j + 1
Set dict = EmptyDict(dict)
Next
End With
WriteOutResults outputSht, results, UBound(stations) + 1
End Sub
Public Function UpdateDictForNoReading(ByVal dict As Object, ByVal currDate As String, ByVal time As String) As Object
'Loop dictionary containing station readings. If current value for key is not an array then no readings where found. _
'then dict is updated with "No reading" for station long text (which includes m e.g. Wien-Schwechat (183m)) and temperature
Dim key As Variant
For Each key In dict
If Not IsArray(dict(key)) Then dict(key) = Array(currDate, time, key, "No reading", "No reading")
Next
Set UpdateDictForNoReading = dict
End Function
Public Sub WriteOutResults(ByVal ws As Worksheet, ByRef results As Variant, ByVal stationCount As Long)
'Loop results array which at each index should have a child array which is comprised of all stations specified _
'The code unravels the nested structure into "flat" array for writing out to sheet. Aim is to be more efficient _
'with writing out to sheet
'The sheet to write results to is passed as argument ws. Headers are stated below.
Dim headers(), outputArr(), i As Long, arr(), j As Long, r As Long, c As Long
headers = Array("Date", "Time", "Station", "StationFull", "Temp")
ReDim outputArr(1 To UBound(results) * stationCount, 1 To UBound(headers) + 1)
For i = LBound(results) To UBound(results)
arr = results(i) '0-6
For j = LBound(arr) To UBound(arr)
r = r + 1
If IsArray(arr(j)) Then
For c = LBound(arr(j)) To UBound(arr(j))
outputArr(r, c + 1) = arr(j)(c)
Next
End If
Next
Next
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(outputArr, 1), UBound(outputArr, 2)) = outputArr
End With
End Sub
Public Function EmptyDict(ByVal dict As Object) As Object
'Ensures no data remains from prior request
Dim key As Variant
For Each key In dict
dict(key) = vbNullString
Next
Set EmptyDict = dict
End Function
Public Function GetAllLinks(ByVal PREFIX As String, ByVal SUFFIX As String) As Object
'Generate all urls between start date time and end date time. Accounts for fact that there is no real midnight. 00:00 uhr retrieves the 23:00 of prior day.
'Times selected on page e.g. 1:00 uhr are one hour ahead of what is used in url string e.g. 1 > 0.
Dim ws As Worksheet, hours(), urls As Collection
Set urls = New Collection
Set ws = ThisWorkbook.Worksheets("Date ranges")
'url "0000" = 1am. The selection of 00:00 in the sheet gives 23:00 of prior date
hours = Array("0000", "0100", "0200", "0300", "0400", "0500", "0600", "0700", "0800", "0900", "1000", "1100", "1200", _
"1300", "1400", "1500", "1600", "1700", "1800", "1900", "2000", "2100", "2200", "2300")
Dim startDate As Date, endDate As Date, startTime As String, endTime As String, currentDate As Date
Dim endIndex As Long, startIndex As Long
With ws
startDate = .Cells(1, 2).Value2 'Required for input yyyy-mm-dd; Required for output yyyymmdd
endDate = .Cells(1, 5).Value2
startTime = .Cells(2, 2)
endTime = .Cells(2, 5)
End With
startIndex = Application.Match(startTime, hours) - 2
endIndex = Application.Match(endTime, hours) - 2
currentDate = startDate
Dim i As Long, s As Long, e As Long
Do While currentDate <= endDate
If startDate = endDate Then
s = startIndex
e = endIndex
Else
Select Case currentDate
Case startDate
s = startIndex
e = UBound(hours)
Case endDate
s = LBound(hours)
e = endIndex
Case Else
s = LBound(hours)
e = UBound(hours)
End Select
End If
For i = s To e
urls.Add PREFIX & Format$(currentDate, "yyyymmdd") & "-" & hours(i) & SUFFIX
Next
currentDate = DateAdd("d", 1, currentDate)
Loop
Set GetAllLinks = urls
End Function
Example output: