Most of the times when the website is as dynamic as this one getting the HTML objects is a lot of work. Also using the Internet explorer is not the fastest of the solutions since we have to wait for the page to reload in most cases.
This is an alternative to getting the data. Do not be scared by the code it's just that I am using quite a few functions to help me along the way.
The idea is to send a Http request and parse the data that was returned in JSON format.
Option Explicit
Dim oScript As Object
Dim oHttp As Object
Sub MainRunner()
Const strAVAILABILITY As String = "https://primenow.amazon.co.uk/fulfillment/availability/"
Dim ws As Worksheet
Dim i As Long
'Initalize variables
Set ws = ThisWorkbook.Worksheets("Postcodes")
Set oScript = CreateObject("MSScriptControl.ScriptControl")
oScript.Language = "JScript"
Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
' Loop through every cell.
i = 1
Do While ws.Cells(i, 1).Value <> vbNullString
ws.Cells(i, 2).Value = GetData(strAVAILABILITY & ws.Cells(i, 1).Value)
i = i + 1
Loop
End Sub
' Retrieves the data using an http request
Function GetData(ByVal strUrl As String) As String
Dim oJson As Object
Dim oAvailability As Object
' Encode the URl in case there are special chars
strUrl = EncodeURL(strUrl)
' Prepare the Http Request
oHttp.Open "GET", strUrl, False
oHttp.send
If oHttp.Status = 200 Then
' Get the JSON object returned
Set oJson = GetJSonObject(oHttp.responseText)
If Not oJson Is Nothing Then
Set oAvailability = GetObjectProperty(oJson, "availability")
If Not oAvailability Is Nothing Then
' Return the information in a string
GetData = ParseAvailabilty(oAvailability)
End If
End If
End If
End Function
' Parse the results into a string.
Function ParseAvailabilty(oAvailabilty As Object) As String
Dim varFinal() As Variant
Dim varData As Variant
Dim i As Long
varData = GetPropertyKeys(oAvailabilty)
ReDim varFinal(UBound(varData))
For i = LBound(varData) To UBound(varData)
varFinal(i) = varData(i) & ":" & GetProperty(oAvailabilty, varData(i))
Next i
'Return the value
ParseAvailabilty = Join(varFinal, ", ")
End Function
' Gets a json object
Public Function GetJSonObject(ByVal strJson As String) As Object
Dim ret As Object
' We wrap it in an error reseum next incase is could not
' be parsed
On Error Resume Next
Set ret = oScript.Eval("(" & strJson & ")")
On Error GoTo 0
' Return the value
Set GetJSonObject = ret
End Function
' Encode URL
Public Function EncodeURL(ByVal URL As String) As Variant
Const strFUNCTION As String = "function encode(o) { return encodeURI(o);}"
oScript.AddCode strFUNCTION
EncodeURL = oScript.Run("encode", URL)
End Function
' Gets the keys from Json object
Public Function GetPropertyKeys(ByVal oJson As Object) As Variant
Const strFUNCTION As String = "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
Dim ret As Variant
If Not oJson Is Nothing Then
oScript.AddCode strFUNCTION
ret = Split(oScript.Run("getKeys", oJson), ",")
End If
' Return the value
GetPropertyKeys = ret
End Function
' Gets a property object from json
Public Function GetObjectProperty(ByVal oJson As Object, _
ByVal strProperty As String) As Object
Const strFUNCTION As String = "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
Dim ret As Object
If Not oJson Is Nothing Then
oScript.AddCode strFUNCTION
If Not IsEmpty(oScript.Run("getProperty", oJson, strProperty)) Then
Set ret = oScript.Run("getProperty", oJson, strProperty)
End If
End If
' Return the value
Set GetObjectProperty = ret
End Function
' Get the value of a property
Public Function GetProperty(ByVal oJson As Object, _
ByVal strProperty As String) As Variant
Const strFUNCTION As String = "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
Dim ret As Variant
If Not oJson Is Nothing Then
oScript.AddCode strFUNCTION
ret = oScript.Run("getProperty", oJson, strProperty)
End If
' Return the value
GetProperty = ret
End Function
This is the early binding version of the code. You can read about late and early binding in this http://www.dicks-clicks.com/excel/olBinding.htm
Also these are the references I am using:
Option Explicit
Dim oScript As New MSScriptControl.ScriptControl
Dim oHttp As New WinHttp.WinHttpRequest
Sub MainRunner()
Const strAVAILABILITY As String = "https://primenow.amazon.co.uk/fulfillment/availability/"
Dim ws As Worksheet
Dim i As Long
'Initalize variables
Set ws = ThisWorkbook.Worksheets("Postcodes")
oScript.Language = "JScript"
' Loop through every cell.
i = 1
Do While ws.Cells(i, 1).Value <> vbNullString
ws.Cells(i, 2).Value = GetData(strAVAILABILITY & ws.Cells(i, 1).Value)
i = i + 1
Loop
End Sub
' Retrieves the data using an http request
Function GetData(ByVal strUrl As String) As String
Dim oJson As Object
Dim oAvailability As Object
' Encode the URl in case there are special chars
strUrl = EncodeURL(strUrl)
' Prepare the Http Request
oHttp.Open "GET", strUrl, False
oHttp.send
If oHttp.Status = 200 Then
' Get the JSON object returned
Set oJson = GetJSonObject(oHttp.responseText)
If Not oJson Is Nothing Then
Set oAvailability = GetObjectProperty(oJson, "availability")
If Not oAvailability Is Nothing Then
' Return the information in a string
GetData = ParseAvailabilty(oAvailability)
End If
End If
End If
End Function
' Parse the results into a string.
Function ParseAvailabilty(oAvailabilty As Object) As String
Dim varFinal() As Variant
Dim varData As Variant
Dim i As Long
varData = GetPropertyKeys(oAvailabilty)
ReDim varFinal(UBound(varData))
For i = LBound(varData) To UBound(varData)
varFinal(i) = varData(i) & ":" & GetProperty(oAvailabilty, varData(i))
Next i
'Return the value
ParseAvailabilty = Join(varFinal, ", ")
End Function
' Gets a json object
Public Function GetJSonObject(ByVal strJson As String) As Object
Dim ret As Object
' We wrap it in an error reseum next incase is could not
' be parsed
On Error Resume Next
Set ret = oScript.Eval("(" & strJson & ")")
On Error GoTo 0
' Return the value
Set GetJSonObject = ret
End Function
' Encode URL
Public Function EncodeURL(ByVal URL As String) As Variant
Const strFUNCTION As String = "function encode(o) { return encodeURI(o);}"
oScript.AddCode strFUNCTION
EncodeURL = oScript.Run("encode", URL)
End Function
' Gets the keys from Json object
Public Function GetPropertyKeys(ByVal oJson As Object) As Variant
Const strFUNCTION As String = "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
Dim ret As Variant
If Not oJson Is Nothing Then
oScript.AddCode strFUNCTION
ret = Split(oScript.Run("getKeys", oJson), ",")
End If
' Return the value
GetPropertyKeys = ret
End Function
' Gets a property object from json
Public Function GetObjectProperty(ByVal oJson As Object, _
ByVal strProperty As String) As Object
Const strFUNCTION As String = "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
Dim ret As Object
If Not oJson Is Nothing Then
oScript.AddCode strFUNCTION
If Not IsEmpty(oScript.Run("getProperty", oJson, strProperty)) Then
Set ret = oScript.Run("getProperty", oJson, strProperty)
End If
End If
' Return the value
Set GetObjectProperty = ret
End Function
' Get the value of a property
Public Function GetProperty(ByVal oJson As Object, _
ByVal strProperty As String) As Variant
Const strFUNCTION As String = "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
Dim ret As Variant
If Not oJson Is Nothing Then
oScript.AddCode strFUNCTION
ret = oScript.Run("getProperty", oJson, strProperty)
End If
' Return the value
GetProperty = ret
End Function
and here there is a slightly faster version of the main procedure. We place the data in an array so excel does does have to work every time data has to be written to the sheet. We write it all at the same tome at the end.
Sub MainRunner()
Const strAVAILABILITY As String = "https://primenow.amazon.co.uk/fulfillment/availability/"
Dim ws As Worksheet
Dim arrData As Variant
Dim lRow As Long
Dim i As Long
'Initalize variables
Set ws = ThisWorkbook.Worksheets("Postcodes")
oScript.Language = "JScript"
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arrData = ws.Cells(1, 1).Resize(lRow, 2).Value
' Loop through every row in the array.
For i = 1 To lRow
arrData(i, 2) = GetData(strAVAILABILITY & arrData(i, 1))
Next i
' Put the data back in the worksheet
ws.Cells(1, 1).Resize(lRow, 2).Value = arrData
End Sub
No Scrip Used
And to our long list of solutions and tried I am adding the solution without the scrip. The scrip is good since it allows us to see the JSON response for what it is a JSON object; but in really its no more than a string so we can get the values from it with a MID function.
Option Explicit
Dim oHttp As New WinHttp.WinHttpRequest
Sub MainRunner()
Const strAVAILABILITY As String = "https://primenow.amazon.co.uk/fulfillment/availability/"
Dim ws As Worksheet
Dim i As Long
'Initalize variables
Set ws = ThisWorkbook.Worksheets("Postcodes")
' Loop through every cell.
i = 1
Do While ws.Cells(i, 1).Value <> vbNullString
ws.Cells(i, 2).Value = GetData(strAVAILABILITY & ws.Cells(i, 1).Value)
i = i + 1
Loop
End Sub
' Retrieves the data using an http request
Function GetData(ByVal strUrl As String) As String
' Encode the URl in case there are special chars
' preserve the protocol
strUrl = URLEncode(strUrl)
' Prepare the Http Request
oHttp.Open "GET", strUrl, False
oHttp.send
If oHttp.Status = 200 Then
' Return the information in a string
GetData = ParseAvailabilty(oHttp.ResponseText)
End If
End Function
' Parse the results into a string.
Function ParseAvailabilty(strJson As String) As String
Const strSTART As String = """availability"":{"
Const strEND As String = "}"
Dim lStart As Long
Dim lEnd As Long
' Determine the location of the markers in the string
lStart = InStr(1, strJson, strSTART)
If Not lStart = 0 Then
lStart = lStart + Len(strSTART) + 1
lEnd = InStr(lStart, strJson, strEND) - 1
If Not lEnd = 0 Then
ParseAvailabilty = Mid$(strJson, lStart, lEnd - lStart)
ParseAvailabilty = Replace$(ParseAvailabilty, """", "")
ParseAvailabilty = Replace$(ParseAvailabilty, ",", ", ")
End If
End If
End Function
' Function to encode URLs
' Used from thie post
' http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba
Function URLEncode(ByVal Text As String) As String
Dim i As Integer
Dim acode As Integer
Dim char As String
URLEncode = Text
For i = Len(URLEncode) To 1 Step -1
acode = Asc(Mid$(URLEncode, i, 1))
Select Case acode
Case 48 To 57, 65 To 90, 97 To 122
' don't touch alphanumeric chars
Case 32
' replace space with "%20"
URLEncode = Left$(URLEncode, i - 1) & "%20" & Mid$(URLEncode, i + 1)
Case 46, 47, 58
' Dont touche ":" or "/"
Case Else
' replace punctuation chars with "%hex"
URLEncode = Left$(URLEncode, i - 1) & "%" & Hex$(acode) & Mid$(URLEncode, i + 1)
End Select
Next
End Function
I hope this helps. :)
