VBA Macro to extract JSON data and post into cells

[yousufj56]

Hi,

I'm thinking that the error is because the url is an HTTPS? I'm getting mismatch type error.

I'm trying to getting the JSON data from this URL: https://min-api.cryptocompare.com/data/price?fsym=ETH&tsyms=USD

This is the code i'm using:

Public Sub exceljson()
Dim http As Object, JSON As Object, i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://min-api.cryptocompare.com/data/price?fsym=ETH&tsyms=USD", False
http.Send
Set JSON = ParseJson(http.responseText)
i = 2
For Each Item In JSON
Sheets(1).Cells(i, 1).Value = Item("USD")


i = i + 1
Next
MsgBox ("complete")
End Sub

 

[Haluk]

Hi again,

Try the following code to fetch the data ....

Sub Test8()
    Dim objHTTP As Object
    Dim MyScript As Object
    Dim i As Long
    Dim myData As Object
    Set MyScript = CreateObject("MSScriptControl.ScriptControl")
    MyScript.Language = "JScript"

    URL = "https://bittrex.com/api/v1.1/public/getorderbook?market=BTC-LTC&type=both"
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    objHTTP.Open "GET", URL, False
    objHTTP.Send
    
    Set RetVal = MyScript.Eval("(" & objHTTP.responseText & ")")
    objHTTP.abort
    
    ActiveSheet.Cells.Clear
    Range("A1:D2").Font.Bold = True
    Range("A1:D2").Font.Color = vbRed
    
    i = 3
    j = 3
    
    Set MyList1 = RetVal.result.buy
    Range("A1") = "Buy"
    Range("A2") = "Quantity"
    Range("B2") = "Rate"
    
    For Each myData In MyList1
        Cells(i, 1).Value = myData.Quantity
        Cells(i, 2).Value = myData.Rate
        i = i + 1
    Next
    
    Set MyList2 = RetVal.result.sell
    Range("C1") = "Sell"
    Range("C2") = "Quantity"
    Range("D2") = "Rate"
    
    For Each myData In MyList2
        Cells(j, 3).Value = myData.Quantity
        Cells(j, 4).Value = myData.Rate
        j = j + 1
    Next

    MsgBox "All data is retrived..."
    
    Set MyList = Nothing
    Set objHTTP = Nothing
    Set MyScript = Nothing
End Sub

 

[yousufj56]

Thanks Haluk. Can we instead do this using:
For x = 1 To Application.CountA(Sheet2.Columns(1)) On Error Resume Next
URL = Sheet2.Cells(x, 1)


That was much easier to work with last time because i can put a list of URLs in sheet2.

 

[Macropod]

Cross-posted at: https://www.excelforum.com/excel-programming-vba-macros/1212519-macro-json-file-object-extract.html
Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html

 

[Haluk]

Take care of the Forum rules and try the following code if the JSon tables have the same structure.

Also; if the below code is suitable for you, post a message on the other site that your problem is solved on MrExcel forum giving a link to this subject.

Sub Test9()
    Dim objHTTP As Object
    Dim MyScript As Object
    Dim x As Integer, NoA As Integer, NoC As Integer
    Dim myData As Object
    Set MyScript = CreateObject("MSScriptControl.ScriptControl")
    MyScript.Language = "JScript"
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    
    Sheets(1).Cells.Clear
    Sheets(1).Range("A1:D2").Font.Bold = True
    Sheets(1).Range("A1:D2").Font.Color = vbRed
    Sheets(1).Range("A1") = "Buy"
    Sheets(1).Range("A2") = "Quantity"
    Sheets(1).Range("B2") = "Rate"
    Sheets(1).Range("C1") = "Sell"
    Sheets(1).Range("C2") = "Quantity"
    Sheets(1).Range("D2") = "Rate"
    
    For x = 1 To Application.CountA(Sheet2.Columns(1))
        URL = Sheets(2).Cells(x, 1)
        objHTTP.Open "GET", URL, False
        objHTTP.Send
        
        If objHTTP.ReadyState = 4 Then
            If objHTTP.Status = 200 Then
            
                Set RetVal = MyScript.Eval("(" & objHTTP.responseText & ")")
                objHTTP.abort
                
                Set MyList1 = RetVal.result.buy
                NoA = Sheet1.Cells(65536, 1).End(xlUp).Row + 1
                
                For Each myData In MyList1
                    Sheets(1).Cells(NoA, 1).Value = myData.Quantity
                    Sheets(1).Cells(NoA, 2).Value = myData.Rate
                    NoA = NoA + 1
                Next
                
                Set MyList2 = RetVal.result.sell
                
                NoC = Sheet1.Cells(65536, 3).End(xlUp).Row + 1
                
                For Each myData In MyList2
                    Sheets(1).Cells(NoC, 3).Value = myData.Quantity
                    Sheets(1).Cells(NoC, 4).Value = myData.Rate
                    NoC = NoC + 1
                Next
            End If
        End If
    Next
    
    MsgBox "All data is retrived..."
    
    Set MyList2 = Nothing
    Set MyList = Nothing
    Set objHTTP = Nothing
    Set MyScript = Nothing
End Sub

 

[yousufj56]

Sorry, yes i will remember this in the future.

The code doesn't work. It give me an error of: method open of object failed

Stops on this line: objHTTP.Open "GET", URL, False

 

[Haluk]

It is working very well on my PC.

Maybe your internet connection is slow and this may produce an error.

 

[yousufj56]

Wait i got it working. I had my sheets the wrong way. But it looks like one data set overrides the other one. Last time we had it pasting below every data pull. Are you seeing the same thing from your side? Try it with these two URLS.

[TABLE="width: 64"]
<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]https://bittrex.com/api/v1.1/public/getorderbook?market=BTC-LTC&type=both

[/TD]
[/TR]
[TR]
[TD]https://bittrex.com/api/v1.1/public/getorderbook?market=BTC-ETH&type=both[/TD]
[/TR]
</tbody>[/TABLE]

 

[yousufj56]

Haluk, i just tried the code on a different spreadsheet and it does work perfectly. Thanks for all your help.

 

[yousufj56]

Hey, in the earlier macros, you had listed the data points. Data-0, Data-1 etc.

Can we add it to this one too? I need to be able to tell which URL each data set belongs too. Every time its Data-0, its a new data set.

This is the code you used before:

[COLOR=#333333] myData = MyScript.Run("getValue", RetVal, 4, "close")[/COLOR]        myLength = MyScript.Run("getLength", RetVal)
        
        'Get all the values of the JSon table under "Data"
        For i = 0 To myLength - 1
            NoA = Sheet1.Cells(65536, 1).End(xlUp).Row + 1
            Sheet1.Range("A" & NoA) = "Data -" &i

 

[MARK858]

Haluk, please be aware of what yousufj56 has posted here