Nog een keer data van een website halen met VBA code. Ga in de Visual Basic Editor naar:
Extra | Verwijzingen en kruis in ieder geval aan:
– Microsoft HTML Object Library
– Microsoft XML, v6.0

De VBA code
Sub Get_That_Data_Version_2()
Dim HTMLdoc As Object
Dim xmlhttp As New MSXML2.XMLHTTP60
Dim allDivs As Object, element As Object
Dim i As Integer
Dim ws As Worksheet
Dim nextRow As Long
' Wijs Sheet1 toe en maak de sheet leeg voor nieuwe data
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Cells.Clear
' Schrijf de kolomkoppen in A1, B1 en C1
ws.Range("A1").Value = "Platform"
ws.Range("B1").Value = "Title"
ws.Range("C1").Value = "Price"
' Zet de startrij voor de data op rij 2
nextRow = 2
Set xmlhttp = New MSXML2.XMLHTTP60
xmlhttp.Open "GET", "https://gameshop.nl/webshop/index.php", False
xmlhttp.send
Set HTMLdoc = CreateObject("htmlfile")
HTMLdoc.body.innerHTML = xmlhttp.responseText
Set allDivs = HTMLdoc.getElementsByTagName("div")
For i = 0 To allDivs.Length - 1
Set element = allDivs.Item(i)
If element.className Like "*product-card*" Then
' Geef het werkblad en de huidige rij mee als argumenten
Extract_Product_Data element, ws, nextRow
End If
Next i
' Kolommen automatisch netjes uitlijnen qua breedte
ws.Columns("A:C").AutoFit
MsgBox "Data succesvol geëxporteerd naar Sheet1!", vbInformation
End Sub
Private Sub Extract_Product_Data(ByVal productBox As Object, ByVal ws As Worksheet, ByRef nextRow As Long)
Dim subElements As Object, subEl As Object
Dim j As Integer
Dim platformText As String, titleText As String, priceText As String
Set subElements = productBox.getElementsByTagName("*")
For j = 0 To subElements.Length - 1
Set subEl = subElements.Item(j)
' 1. PLATFORM
If UCase(subEl.tagName) = "A" Then
If subEl.getAttribute("href") Like "*platform=*" Then
platformText = subEl.innerText
End If
End If
' 2. TITEL
If UCase(subEl.tagName) = "H3" Then
If subEl.getElementsByTagName("a").Length > 0 Then
titleText = subEl.getElementsByTagName("a").Item(0).innerText
Else
titleText = subEl.innerText
End If
End If
' 3. PRIJS
If subEl.className Like "*prijs*" Then
priceText = subEl.innerText
End If
Next j
' Schrijf het resultaat naar Sheet1 in plaats van het Immediate Window
If titleText <> "" Or priceText <> "" Then
ws.Cells(nextRow, 1).Value = Trim(platformText) ' Kolom A
ws.Cells(nextRow, 2).Value = Trim(titleText) ' Kolom B
ws.Cells(nextRow, 3).Value = Trim(priceText) ' Kolom C
' Hoog de rij-teller op voor het volgende product
nextRow = nextRow + 1
End If
End Sub