i am trying to scrape date from https://www.jjfox.co.uk/aj-fernandez-bellas-artes-maduro.html using Json parser with the following code. the code does not however render any results. this is partially related to a question asked and answered earlier in here, however teh code has stoped working: Scraping website data with options in combo box VBA
Option Explicit
Sub collectData()
Dim I As Integer
Dim bb As String
Dim a(1 To 1) As String
a(1) = "https://www.jjfox.co.uk/cigars/view-all.html?product_list_limit=all&product_list_order=name"
'a(2) = "https://www.jjfox.co.uk/best-sellers/show/all.html"
'a(3) = "https://www.jjfox.co.uk/new-arrivals/show/all.html"
'a(4) = "https://www.jjfox.co.uk/cigar-accessories/show/all.html"
'a(5) = "https://www.jjfox.co.uk/cigar-gifts/show/all.html"
For I = 1 To UBound(a)
bb = texter(a(I))
Next I
End Sub
Public Function texter(ntx As String)
Dim cnt As Integer
Dim counter1 As Integer
Dim oHtml As HTMLDocument
Dim oElement As Object
Dim elm As Object
Set oHtml = New HTMLDocument
With CreateObject("MSXML2.ServerXMLHTTP.6.0")
.Open "GET", ntx, False
.send
oHtml.body.innerHTML = .responseText
End With
Dim innerlink As String
counter1 = cnt
Set oElement = oHtml.getElementsByClassName("products wrapper grid products-grid")(0).getElementsByTagName("a")
For Each elm In oElement
'If elm.className = "products-grid products-grid--max-3-col" Then
innerlink = elm.href
Debug.Print elm.href
GetCigarData (innerlink)
'End If
Next
End Function
Public Sub GetCigarData(hh As String)
'< VBE > Tools > References:
'Microsoft Scripting Runtime
'Microsoft HTML Object Library
'Microsoft XML Library
Dim json As Object, html As MSHTML.HTMLDocument, xhr As MSXML2.XMLHTTP60, ws As Worksheet
Dim nme As Variant
Set ws = ThisWorkbook.Worksheets("JJFox")
ws.Activate
Set xhr = New MSXML2.XMLHTTP60
Set html = New MSHTML.HTMLDocument
Dim lastrow As Double
Dim cnt As Double
Cells(1, 1).Select
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
cnt = lastrow + 1
Dim nump As Long
nme = hh
If hh <> "" Then
If InStr(1, hh, "sampl", vbTextCompare) = 0 And InStr(1, hh, "best-of", vbTextCompare) = 0 And InStr(1, hh, "mini", vbTextCompare) = 0 And InStr(1, hh, "leather-case", vbTextCompare) = 0 And InStr(1, hh, "club", vbTextCompare) = 0 And InStr(1, hh, "box", vbTextCompare) = 0 And InStr(1, hh, "single", vbBinaryCompare) = 0 Then
With xhr
.Open "GET", hh, False
.setRequestHeader "User-Agent", "Mozilla/5.0"
.send
html.body.innerHTML = .responseText
End With
On Error Resume Next
Set json = JsonConverter.ParseJson(html.querySelector(".fieldset [type='text/x-magento-init']").innerHTML)("#product_addtocart_form")("configurable")("spConfig")
Dim prices As Scripting.dictionary, options As Scripting.dictionary, optionsCollection As Collection
Set prices = json("optionPrices")
Set options = json("attributes")
Set optionsCollection = options(options.Keys(0))("options")
Dim results() As Variant, headers() As Variant, I As Long, name As String
ReDim results(1 To optionsCollection.Count, 1 To 7)
name = html.querySelector(".base").innerText
Debug.Print name
For I = 1 To optionsCollection.Count
results(I, 1) = name
results(I, 2) = optionsCollection.Item(I)("label")
results(I, 3) = prices(prices.Keys(I - 1))("finalPrice")("amount")
results(I, 4) = "JJFox"
results(I, 5) = Now()
results(I, 6) = ""
results(I, 7) = nme
Next
'headers = Array("Name", "Size", "Price")
With ws
'.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(cnt, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End If
End If
Cells(lastrow, 7).Select
Selection.AutoFill Destination:=Range(Cells(lastrow, 7), Cells(cnt, 7))
End Sub
The part that does not work is this, as it returns Nothing every time and i have no idea why:
Set json = JsonConverter.ParseJson(html.querySelector(".fieldset [type='text/x-magento-init']").innerHTML)("#product_addtocart_form")("configurable")("spConfig")
Dim prices As Scripting.dictionary, options As Scripting.dictionary, optionsCollection As Collection
Set prices = json("optionPrices")
Set options = json("attributes")
Set optionsCollection = options(options.Keys(0))("options")
