Unable to parse two fields from all the containers out of some json response in the right way

user_7180194 0
Viewed 194

I'm trying to fetch two fields from each container from some json response using regex. When I execute the script that I've written so far can produce the two fields from all the containers. However, the way I've defined the last loop doesn't seem to be an ideal one. To be clearer, I used the count of name and created a loop to parse the required fields. If the count of names and changeAmount are different the results will be real messy. How can I rectify the loop to scrape the two fields in the right way?

I've tried with (working script):

Sub FetchContent()
    Const Url$ = "https://api-global.morningstar.com/sal-service/v1/stock/ownership/v1/0P000000GY/OwnershipData/mutualfund/20/data?locale=en&clientId=MDC&benchmarkId=category&version=3.21.1"
    Dim elem As Object, oelem As Object, I&, R&, S$
    Dim Http As Object, Rgxp As Object, wb As Workbook, ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Set Rgxp = CreateObject("VBScript.RegExp")

    With Http
        .Open "GET", Url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; ) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/81.0.4044.138 Safari/537.36"
        .setRequestHeader "ApiKey", "lstzFDEOhfFNMLikKa0am9mgEKLBl49T"
        .send
        S = .responseText
    End With

    With Rgxp
        .Global = True
        .MultiLine = True

        .Pattern = "name"":""(.*?)"""
        Set elem = .Execute(S)

        .Pattern = "changeAmount"":(.*?),"
        Set oelem = .Execute(S)
    End With

    For I = 0 To elem.Count - 1
        R = R + 1: ws.Cells(R, 1) = elem(I).SubMatches(0)
        ws.Cells(R, 2) = oelem(I).SubMatches(0)
    Next I
End Sub

The following content represents how the first three containers look like:

{
    "secId": "FOUSA00FQU",
    "name": "Vanguard Total Stock Mkt Idx Inv",
    "totalSharesHeld": 2.564925871507663,
    "totalAssets": 4.16033,
    "currentShares": 115913617,
    "changeAmount": -1331374,
    "changePercentage": -1.1355487246359206,
    "date": "2020-04-30T00:00:00.000",
    "trend": "_PO_",
    "starRating": "4"
},
{
    "secId": "FOUSA00FS1",
    "name": "Vanguard 500 Index Investor",
    "totalSharesHeld": 1.8912105957275436,
    "totalAssets": 5.08629,
    "currentShares": 85467211,
    "changeAmount": -487891,
    "changePercentage": -0.5676114490562759,
    "date": "2020-04-30T00:00:00.000",
    "trend": "_PO_",
    "starRating": "4"
},
{
    "secId": "FEUSA00001",
    "name": "SPDR\u00ae S&P 500 ETF Trust",
    "totalSharesHeld": 0.994538610986949,
    "totalAssets": 5.07929,
    "currentShares": 44944990,
    "changeAmount": -436740,
    "changePercentage": -0.9623696584506585,
    "date": "2020-04-30T00:00:00.000",
    "trend": "_PO_",
    "starRating": "5"
}

How can I fetch the two fields from all the containers?

PS I'm not after any solution related to any json converter.

web-scraping vba regex
3 Answers
Option Explicit

Sub FetchContent()

    Const url = "https://api-global.morningstar.com/sal-service/v1/stock/ownership/v1/0P000000GY/OwnershipData/mutualfund/20/data?locale=en&clientId=MDC&benchmarkId=category&version=3.21.1"
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = wb.Worksheets("Sheet1")
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; ) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/81.0.4044.138 Safari/537.36"
        .setRequestHeader "ApiKey", "lstzFDEOhfFNMLikKa0am9mgEKLBl49T"
        .send
        Dim resp
        resp = .responseText
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .pattern = "\{[^}]*""name""\:""(.*?)"",.*?""changeAmount""\:([-.\d]*),"
        Dim r
        r = 1
        Dim item
        For Each item In .Execute(resp)
            ws.Cells(r, 1) = decodeJsonString(item.SubMatches(0))
            ws.Cells(r, 2) = decodeJsonString(item.SubMatches(1))
            r = r + 1
        Next
    End With

End Sub

Function decodeJsonString(jsonString)

    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        decodeJsonString = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
            jsonString, _
            "\""", """"), _
            "\\", "\" & vbNullChar), _
            "\/", "/"), _
            "\b", Chr(8)), _
            "\f", Chr(12)), _
            "\n", vbLf), _
            "\r", vbCr), _
            "\t", vbTab)
        .Global = False
        .pattern = "\\u[0-9a-fA-F]{4}"
        Do While .test(decodeJsonString)
            decodeJsonString = .Replace(decodeJsonString, ChrW(("&H" & Right(.Execute(decodeJsonString)(0).Value, 4)) * 1))
        Loop
        decodeJsonString = Replace(decodeJsonString, "\" & vbNullChar, "\")
    End With

End Function
user_21657590

You forgot opening quote:

.Pattern = """name"":""(.*?)"""
.Pattern = """changeAmount"":(.*?),"
user_31870330

This is another way I found success with apart from what omegastripes has showed in his answer:

Sub FetchContent()
    Const Url$ = "https://api-global.morningstar.com/sal-service/v1/stock/ownership/v1/0P000000GY/OwnershipData/mutualfund/20/data?locale=en&clientId=MDC&benchmarkId=category&version=3.21.1"
    Dim elem As Object, I&, R&, S$, wb As Workbook
    Dim Http As Object, Rgxp As Object, ws As Worksheet
    Dim subElem As Object, subElemAno As Object

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Set Rgxp = CreateObject("VBScript.RegExp")

    With Http
        .Open "GET", Url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; ) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/81.0.4044.138 Safari/537.36"
        .setRequestHeader "ApiKey", "lstzFDEOhfFNMLikKa0am9mgEKLBl49T"
        .send
        S = .responseText
    End With

    With Rgxp
        .Global = True
        .MultiLine = True

        .Pattern = "{""secId[\s\S]+?}"
        Set elem = .Execute(S)

        For I = 0 To elem.Count - 1
            .Pattern = "name"":""(.*?)"""
            Set subElem = .Execute(elem(I).Value)
            If subElem.Count > 0 Then
                R = R + 1: ws.Cells(R, 1) = subElem(0).SubMatches(0)
            End If

            .Pattern = "changeAmount"":(.*?),"
            Set subElemAno = .Execute(elem(I).Value)
            If subElemAno.Count > 0 Then
                ws.Cells(R, 2) = subElemAno(0).SubMatches(0)
            End If
        Next I
    End With
End Sub
user_91897990
Related