VBA macro to extract web content

D

drkjz

New Member
Joined
Jul 12, 2020
Messages
10
Office Version
  1. 365
Platform
  1. Windows
This is my first attempt to extract web content. I found a similar post at VBA Macro to extract JSON data and post into cells with a response from Haluk. I can get the code to work on the original web content page but I cannot get it to work on the page I am interested in extracting data from (e.g., https://query1.finance.yahoo.com/v7...l=15m&indicators=quote&includeTimestamps=true). When I run the code below, I get a run-time error 438: object doesn't support this property or method at Set=NewMyList = NewRetVal.Data. I am assuming it is because the format of the data is slightly different but I don't know how to change it.

I don't need the data that has problems with reserved words, but I am curious if there is a way to still extract that data.

VBA Code: 
Sub Test4() ' modified code from Haluk on mrexcel.com
    Dim objHTTP As Object
    Dim NewobjHTTP As Object
    Dim MyScript As Object
    Dim NewMyScript As Object
    Dim i As Long
    Dim myData As Object
    Dim NewmyData As Object
        
    Set MyScript = CreateObject("MSScriptControl.ScriptControl")
    MyScript.Language = "JScript"
    
    Url = "https://min-api.cryptocompare.com/data/histominute?fsym=BTC&tsym=USD&limit=60&aggregate=3&e=CCCAGG"
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    objHTTP.Open "GET", Url, False
    objHTTP.send
    
    Set RetVal = MyScript.Eval("(" + objHTTP.responsetext + ")")
    objHTTP.abort
    
    i = 2
    
    Set MyList = RetVal.Data
    
    For Each myData In MyList
'        Cells(i, 1).Value = myData.Time
'        Cells(i, 2).Value = myData.Close
        Cells(i, 3).Value = myData.high
        Cells(i, 4).Value = myData.low
'        Cells(i, 5).Value = myData.Open
        Cells(i, 6).Value = myData.volumefrom
        Cells(i, 7).Value = myData.volumeto
        i = i + 1
    Next
    
' attempting a different page
    Set NewMyScript = CreateObject("MSScriptControl.ScriptControl")
    NewMyScript.Language = "JScript"
    
    NewUrl = "https://query1.finance.yahoo.com/v7/finance/chart/DXCM?range=1d&interval=15m&indicators=quote&includeTimestamps=true"
    
    Set NewobjHTTP = CreateObject("MSXML2.XMLHTTP")
    NewobjHTTP.Open "GET", NewUrl, False
    NewobjHTTP.send
    
    Set NewRetVal = MyScript.Eval("(" + NewobjHTTP.responsetext + ")")
    NewobjHTTP.abort
    
    i = 2
    
    Set NewMyList = NewRetVal.Data
    
    For Each NewmyData In NewMyList
        Cells(i, 11).Value = NewmyData.timestamp
        Cells(i, 12).Value = NewmyData.low
        Cells(i, 13).Value = NewmyData.volume
'        Cells(i, 14).Value = NewmyData.Open
'        Cells(i, 15).Value = NewmyData.Close
        Cells(i, 16).Value = NewmyData.high
        i = i + 1
    Next
    
    Set NewMyList = Nothing
    Set NewobjHTTP = Nothing
    Set NewMyScript = Nothing
End Sub
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
Welcome to MrExcel forums.
drkjz said:
... I cannot get it to work on the page I am interested in extracting data from (e.g., https://query1.finance.yahoo.com/v7...l=15m&indicators=quote&includeTimestamps=true). When I run the code below, I get a run-time error 438: object doesn't support this property or method at Set=NewMyList = NewRetVal.Data. I am assuming it is because the format of the data is slightly different but I don't know how to change it.

I don't need the data that has problems with reserved words, but I am curious if there is a way to still extract that data.
Click to expand...
You're correct; the error occurs on that line because the NewRetVal JSON object (created by the MyScript.Eval line from the JSON response string) doesn't have a first-level property named "Data". This screen shot shows the JSON structure for your URL:

1594675819039.png

Which shows the timestamp object and its array of values are at chart->result->0->timestamp. Similarly, the open values are at chart->result->0>indicators->quote->0->open:

1594676082799.png

Furthermore, the object.PropertyName method of accessing JSON properties in VBA has problems when the JSON property name is the same as a VBA keyword which has a different case. VBA changes the property name you type to the same case as the keyword, which means the code can't access that JSON property if its case is different. Therefore a different approach is needed to access and extract the JSON property values.

There are several VBA JSON parsers available, including VBA-JSON which is probably the best and fastest. The syntax it uses for accessing JSON objects and properties is simple and natural because it creates a data structure of VBA Dictionaries and Collections and you specify the property name as the Dictionary key or Collection item number, as shown in this example:

www.mrexcel.com

Parse JSON into Excel

Hi I have been using the Jsonconverter vba parser available via https://github.com/VBA-tools/VBA-JSON to extract the data from json files such as https://stats.europeantour.com/v1/season/2019/players/strokes-gained/off-the-tee. This has been very easy to set up and it works. However, the...
www.mrexcel.com www.mrexcel.com

Your code uses the JSON parsing capability of the Microsoft ScriptControl. However, your code calls the ScriptControl's Eval method to parse the JSON string response and this is a security risk because a malicious JSON string could be executed - finance.yahoo.com could be considered safe and reliable, but you never know! Instead of Eval, my code below uses the ScriptControl's Run method to parse the JSON string using the safe JSON_parse function described at VBA - Parse JSON safer with JSON.Parse and not Eval.

You will see that the Create_Script function below includes the mentioned JSON_parse function and several other JavaScript functions for accessing JSON properties and values. Most useful is the getObjByPath function which allows you to specify a comma-separated path of object names (e.g. "chart,result,0") to directly reference the last object name in the path, instead of having to drill down and reference each object one by one.

This code extracts the timestamp, volume, open, high, low and close values and writes them to the first sheet in the workbook.

VBA Code: 
Option Explicit

Public Sub Extract_JSON_Data()

    Dim Script As Object
    Dim XMLhttp As Object
    Dim URL As String
    Dim JSONobj As Object
    Dim quote0 As Object, result0 As Object
    Dim timestamp As Object, volume As Object, openx As Object, high As Object, low As Object, closex As Object
    Dim keys As Variant, key As Variant
    Dim ts As Double
    Dim data() As Variant, dataSize As Long
    Dim destCell As Range
  
    Set Script = Create_Script
  
    With Worksheets(1)
        .Cells.ClearContents
        .Range("A1:F1").Value = Split("Timestamp,Volume,Open,High,Low,Close", ",")
        Set destCell = .Range("A2")
    End With
  
    URL = "https://query1.finance.yahoo.com/v7/finance/chart/DXCM?range=1d&interval=15m&indicators=quote&includeTimestamps=true"
  
    Set JSONobj = Nothing
    Set XMLhttp = CreateObject("MSXML2.XMLHTTP")
    With XMLhttp
        .Open "GET", URL, False
        .send
        If .Status = 200 Then
            Set JSONobj = Script.Run("JSON_parse", .responseText)
        End If
    End With
  
    If Not JSONobj Is Nothing Then
      
        'Get chart -> result -> 0 from main JSON object
              
        Set result0 = Script.Run("getObjByPath", JSONobj, "chart,result,0")
             
        'Get timestamp collection from chart -> result -> 0 element
      
        Set timestamp = Script.Run("getObj", result0, "timestamp")
      
        'Get indicators -> quote -> 0 from chart -> result -> 0 element
      
        Set quote0 = Script.Run("getObjByPath", result0, "indicators,quote,0")
      
        'Get volume, open, high, low and close collections from indicators -> quote -> 0 element
      
        Set volume = Script.Run("getObj", quote0, "volume")
        Set openx = Script.Run("getObj", quote0, "open")
        Set high = Script.Run("getObj", quote0, "high")
        Set low = Script.Run("getObj", quote0, "low")
        Set closex = Script.Run("getObj", quote0, "close")
              
        Set keys = Script.Run("getKeys", timestamp)
      
        dataSize = Script.Run("length", volume)
        ReDim data(0 To dataSize - 1, 0 To 5)
      
        'Fill data array with timestamp, volume, open, high, low and close values
      
        For Each key In keys
            ts = Script.Run("getItemByKey", timestamp, key)
            data(key, 0) = CvtTimestamp(ts)
            data(key, 1) = Script.Run("getItemByKey", volume, key)
            data(key, 2) = Script.Run("getItemByKey", openx, key)
            data(key, 3) = Script.Run("getItemByKey", high, key)
            data(key, 4) = Script.Run("getItemByKey", low, key)
            data(key, 5) = Script.Run("getItemByKey", closex, key)
        Next
     
        'Write data array to cells
      
        destCell.Resize(dataSize, UBound(data, 2) + 1).Value = data

    End If
  
End Sub


'Based on http://exceldevelopmentplatform.blogspot.com/2018/01/vba-parse-json-safer-with-jsonparse-and.html
'Uses late binding of ScriptControl, so no VBA references needed

Private Function Create_Script() As Object

    Dim soSC As Object 'ScriptControl
  
    If soSC Is Nothing Then

        'Set soSC = New ScriptControl
        Set soSC = CreateObject("MSScriptControl.ScriptControl")
      
        soSC.Language = "JScript"
        soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "
        soSC.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; }"
        soSC.AddCode "function getObj(jsonObj, objName) { return jsonObj[objName]; }"
        soSC.AddCode "function getObjByPath(jsonObj, path) { var parts = path.split(','); for (var i in parts) { jsonObj = jsonObj[parts[i]]; } return jsonObj; }"
        soSC.AddCode "function getItemByKey(jsonObj, key) { return jsonObj[key]; }"
        soSC.AddCode "function length(jsonObj) { return jsonObj.length; }"
  
    End If
  
    Set Create_Script = soSC
  
End Function


Private Function GetJavaScriptLibrary(ByVal sURL As String) As String
  
    Dim XMLhttp As Object
    Set XMLhttp = CreateObject("MSXML2.XMLHTTP")
    With XMLhttp
        .Open "GET", sURL, False
        .send
        GetJavaScriptLibrary = .responseText
    End With

End Function


'Convert Unix timestamp (number of seconds since 01-Jan-1970) to an Excel Date time
Private Function CvtTimestamp(timestamp As Double) As Date
    CvtTimestamp = DateAdd("s", timestamp, DateSerial(1970, 1, 1))
End Function
 
Last edited:
Upvote 0
John_w said:
Welcome to MrExcel forums.
You're correct; the error occurs on that line because the NewRetVal JSON object (created by the MyScript.Eval line from the JSON response string) doesn't have a first-level property named "Data". This screen shot shows the JSON structure for your URL:

View attachment 18117

Which shows the timestamp object and its array of values are at chart->result->0->timestamp. Similarly, the open values are at chart->result->0>indicators->quote->0->open:

View attachment 18118

Furthermore, the object.PropertyName method of accessing JSON properties in VBA has problems when the JSON property name is the same as a VBA keyword which has a different case. VBA changes the property name you type to the same case as the keyword, which means the code can't access that JSON property if its case is different. Therefore a different approach is needed to access and extract the JSON property values.

There are several VBA JSON parsers available, including VBA-JSON which is probably the best and fastest. The syntax it uses for accessing JSON objects and properties is simple and natural because it creates a data structure of VBA Dictionaries and Collections and you specify the property name as the Dictionary key or Collection item number, as shown in this example:

www.mrexcel.com

Parse JSON into Excel

Hi I have been using the Jsonconverter vba parser available via https://github.com/VBA-tools/VBA-JSON to extract the data from json files such as https://stats.europeantour.com/v1/season/2019/players/strokes-gained/off-the-tee. This has been very easy to set up and it works. However, the...
www.mrexcel.com www.mrexcel.com

Your code uses the JSON parsing capability of the Microsoft ScriptControl. However, your code calls the ScriptControl's Eval method to parse the JSON string response and this is a security risk because a malicious JSON string could be executed - finance.yahoo.com could be considered safe and reliable, but you never know! Instead of Eval, my code below uses the ScriptControl's Run method to parse the JSON string using the safe JSON_parse function described at VBA - Parse JSON safer with JSON.Parse and not Eval.

You will see that the Create_Script function below includes the mentioned JSON_parse function and several other JavaScript functions for accessing JSON properties and values. Most useful is the getObjByPath function which allows you to specify a comma-separated path of object names (e.g. "chart,result,0") to directly reference the last object name in the path, instead of having to drill down and reference each object one by one.

This code extracts the timestamp, volume, open, high, low and close values and writes them to the first sheet in the workbook.

VBA Code: 
Option Explicit

Public Sub Extract_JSON_Data()

    Dim Script As Object
    Dim XMLhttp As Object
    Dim URL As String
    Dim JSONobj As Object
    Dim quote0 As Object, result0 As Object
    Dim timestamp As Object, volume As Object, openx As Object, high As Object, low As Object, closex As Object
    Dim keys As Variant, key As Variant
    Dim ts As Double
    Dim data() As Variant, dataSize As Long
    Dim destCell As Range
 
    Set Script = Create_Script
 
    With Worksheets(1)
        .Cells.ClearContents
        .Range("A1:F1").Value = Split("Timestamp,Volume,Open,High,Low,Close", ",")
        Set destCell = .Range("A2")
    End With
 
    URL = "https://query1.finance.yahoo.com/v7/finance/chart/DXCM?range=1d&interval=15m&indicators=quote&includeTimestamps=true"
 
    Set JSONobj = Nothing
    Set XMLhttp = CreateObject("MSXML2.XMLHTTP")
    With XMLhttp
        .Open "GET", URL, False
        .send
        If .Status = 200 Then
            Set JSONobj = Script.Run("JSON_parse", .responseText)
        End If
    End With
 
    If Not JSONobj Is Nothing Then
     
        'Get chart -> result -> 0 from main JSON object
             
        Set result0 = Script.Run("getObjByPath", JSONobj, "chart,result,0")
            
        'Get timestamp collection from chart -> result -> 0 element
     
        Set timestamp = Script.Run("getObj", result0, "timestamp")
     
        'Get indicators -> quote -> 0 from chart -> result -> 0 element
     
        Set quote0 = Script.Run("getObjByPath", result0, "indicators,quote,0")
     
        'Get volume, open, high, low and close collections from indicators -> quote -> 0 element
     
        Set volume = Script.Run("getObj", quote0, "volume")
        Set openx = Script.Run("getObj", quote0, "open")
        Set high = Script.Run("getObj", quote0, "high")
        Set low = Script.Run("getObj", quote0, "low")
        Set closex = Script.Run("getObj", quote0, "close")
             
        Set keys = Script.Run("getKeys", timestamp)
     
        dataSize = Script.Run("length", volume)
        ReDim data(0 To dataSize - 1, 0 To 5)
     
        'Fill data array with timestamp, volume, open, high, low and close values
     
        For Each key In keys
            ts = Script.Run("getItemByKey", timestamp, key)
            data(key, 0) = CvtTimestamp(ts)
            data(key, 1) = Script.Run("getItemByKey", volume, key)
            data(key, 2) = Script.Run("getItemByKey", openx, key)
            data(key, 3) = Script.Run("getItemByKey", high, key)
            data(key, 4) = Script.Run("getItemByKey", low, key)
            data(key, 5) = Script.Run("getItemByKey", closex, key)
        Next
    
        'Write data array to cells
     
        destCell.Resize(dataSize, UBound(data, 2) + 1).Value = data

    End If
 
End Sub


'Based on http://exceldevelopmentplatform.blogspot.com/2018/01/vba-parse-json-safer-with-jsonparse-and.html
'Uses late binding of ScriptControl, so no VBA references needed

Private Function Create_Script() As Object

    Dim soSC As Object 'ScriptControl
 
    If soSC Is Nothing Then

        'Set soSC = New ScriptControl
        Set soSC = CreateObject("MSScriptControl.ScriptControl")
     
        soSC.Language = "JScript"
        soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "
        soSC.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; }"
        soSC.AddCode "function getObj(jsonObj, objName) { return jsonObj[objName]; }"
        soSC.AddCode "function getObjByPath(jsonObj, path) { var parts = path.split(','); for (var i in parts) { jsonObj = jsonObj[parts[i]]; } return jsonObj; }"
        soSC.AddCode "function getItemByKey(jsonObj, key) { return jsonObj[key]; }"
        soSC.AddCode "function length(jsonObj) { return jsonObj.length; }"
 
    End If
 
    Set Create_Script = soSC
 
End Function


Private Function GetJavaScriptLibrary(ByVal sURL As String) As String
 
    Dim XMLhttp As Object
    Set XMLhttp = CreateObject("MSXML2.XMLHTTP")
    With XMLhttp
        .Open "GET", sURL, False
        .send
        GetJavaScriptLibrary = .responseText
    End With

End Function


'Convert Unix timestamp (number of seconds since 01-Jan-1970) to an Excel Date time
Private Function CvtTimestamp(timestamp As Double) As Date
    CvtTimestamp = DateAdd("s", timestamp, DateSerial(1970, 1, 1))
End Function
Click to expand...


This worked perfectly! Thanks for the explanation too so that I can try to implement it further later.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Having Trouble getting this code in VBA to work. Attempting to download a list of PDFs
Replies
1
Views
125
6StringJazzer
6StringJazzer
E
  • Solved
Deleting contents of Json object in VBA
Replies
5
Views
241
Edsancar
E
S
  • Question Question
VBA : Reflection Workspace extract all screen/pages
Replies
0
Views
101
Samantha27
S
S
  • Question Question
Excel VBA for Yahoo Finance
Replies
5
Views
581
alansidman
A
G
  • Solved
run VBA when clicked
Replies
4
Views
116
Gylle
G

Forum statistics

Threads
1,223,903
Messages
6,175,279
Members
452,630
Latest member
OdubiYouth

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top