在Excel上解析JSON（2003-2013）

Question

我目前正尝试通过链接将可刷新的JSON Feed导入Excel。我遇到过代码来帮助我处理另一个page但是在运行时会产生错误

Run-time error '-2147467259 (80004005)': Unspecified error) on
"strMarkerQuot = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)". 

我是否可以按原样执行此代码或从单元格解析或提取数据的任何其他方法获得帮助（到目前为止只设法将完整的JSON写入单元格）

如果需要，这是指向JSON feed的链接。

Option Explicit

Sub Test()

    Dim strJsonString As String
    Dim arrResult() As Variant

    ' download
    strJsonString = DownloadJson("https://apilayer.net/api/live?access_key=4429e7caecf213b559496b1548f5f529&currencies=EUR,USD,AUD,BRL,CAD,CNY,CZK,DKK,XCD,EGP,HKD,HUF,INR,JPY,MYR,NZD,NOK,PLN,SGD,ZAR,SEK,CHF,THB,TRY,AED,BHD,BBD,IDR,ILS,JMD,JOD,KES,KWD,MUR,MAD,OMR,PKR,PHP,QAR,RUB,SAR,KRW,LKR,TWD,TTD,TND,BWP,BGN,CLP,COP,CRC,HRK,DOP,FJD,GMD,GTQ,ISK,MXN,RON,VND,PEN,ARS,BAM,BDT,BMD,BND,BOB,BSD,BZD,KYD,LBP,MOP,NAD,NPR,RSD,UAH&source=GBP&format=1")

    ' process
    arrResult = ConvertJsonToArray(strJsonString)

    ' output
    Output Sheets(1), arrResult

End Sub

Function DownloadJson(strUrl As String) As String

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", strUrl
        .Send
        If .Status <> 200 Then
            Debug.Print .Status
            Exit Function
        End If
        DownloadJson = .responseText
    End With

End Function


Function ConvertJsonToArray(strJsonString As String) As Variant

    Dim strCnt As String
    Dim strMarkerQuot As String
    Dim arrUnicode() As String
    Dim arrQuots() As String
    Dim arrRows() As String
    Dim arrProps() As String
    Dim arrTokens() As String
    Dim arrHeader() As String
    Dim arrColumns() As Variant
    Dim arrColumn() As Variant
    Dim arrTable() As Variant
    Dim j As Long
    Dim i As Long
    Dim lngMaxRowIdx As Long
    Dim lngMaxColIdx As Long
    Dim lngPrevIdx As Long
    Dim lngFoundIdx As Long
    Dim arrProperty() As String
    Dim strPropName As String
    Dim strPropValue As String

    strCnt = Split(strJsonString, "{")(1)
    strCnt = Split(strCnt, "}")(0)

    strMarkerQuot = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
    strCnt = Replace(strCnt, "\\", "\")
    strCnt = Replace(strCnt, "\""", strMarkerQuot)
    strCnt = Replace(strCnt, "\/", "/")
    strCnt = Replace(strCnt, "\b", Chr(8))
    strCnt = Replace(strCnt, "\f", Chr(12))
    strCnt = Replace(strCnt, "\n", vbLf)
    strCnt = Replace(strCnt, "\r", vbCr)
    strCnt = Replace(strCnt, "\t", vbTab)

    arrUnicode = Split(strCnt, "\u")
    For i = 1 To UBound(arrUnicode)
        arrUnicode(i) = ChrW(CLng("&H" & Left(arrUnicode(i), 4))) & Mid(arrUnicode(i), 5)
    Next
    strCnt = Join(arrUnicode, "")

    arrQuots = Split(strCnt, """")
    ReDim arrTokens(UBound(arrQuots) \ 2)
    For i = 1 To UBound(arrQuots) Step 2
        arrTokens(i \ 2) = Replace(arrQuots(i), strMarkerQuot, """")
        arrQuots(i) = "%" & i \ 2
    Next

    strCnt = Join(arrQuots, "")
    strCnt = Replace(strCnt, " ", "")

    arrRows = Split(strCnt, "},{")
    lngMaxRowIdx = UBound(arrRows)
    For j = 0 To lngMaxRowIdx
        lngPrevIdx = -1
        arrProps = Split(arrRows(j), ",")
        For i = 0 To UBound(arrProps)
            arrProperty = Split(arrProps(i), ":")
            strPropName = arrProperty(0)
            If Left(strPropName, 1) = "%" Then strPropName = arrTokens(Mid(strPropName, 2))
            lngFoundIdx = GetArrayItemIndex(arrHeader, strPropName)
            If lngFoundIdx = -1 Then
                ReDim arrColumn(lngMaxRowIdx)
                If lngPrevIdx = -1 Then
                    ArrayAddItem arrHeader, strPropName
                    lngPrevIdx = UBound(arrHeader)
                    ArrayAddItem arrColumns, arrColumn
                Else
                    lngPrevIdx = lngPrevIdx + 1
                    ArrayInsertItem arrHeader, lngPrevIdx, strPropName
                    ArrayInsertItem arrColumns, lngPrevIdx, arrColumn
                End If
            Else
                lngPrevIdx = lngFoundIdx
            End If
            strPropValue = arrProperty(1)
            If Left(strPropValue, 1) = "%" Then strPropValue = arrTokens(Mid(strPropValue, 2))
            arrColumns(lngPrevIdx)(j) = strPropValue
        Next
    Next
    lngMaxColIdx = UBound(arrHeader)
    ReDim arrTable(lngMaxRowIdx + 1, lngMaxColIdx)
    For i = 0 To lngMaxColIdx
        arrTable(0, i) = arrHeader(i)
    Next
    For j = 0 To lngMaxRowIdx
        For i = 0 To lngMaxColIdx
            arrTable(j + 1, i) = arrColumns(i)(j)
        Next
    Next

    ConvertJsonToArray = arrTable

End Function

Sub Output(objSheet As Worksheet, arrCells() As Variant)

    With objSheet
        .Select
        .Range(.Cells(1, 1), Cells(UBound(arrCells, 1) + 1, UBound(arrCells, 2) + 1)).Value = arrCells
        .Columns.AutoFit
    End With
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With

End Sub

Function GetArrayItemIndex(arrElements, varTest)
    For GetArrayItemIndex = 0 To SafeUBound(arrElements)
        If arrElements(GetArrayItemIndex) = varTest Then Exit Function
    Next
    GetArrayItemIndex = -1
End Function

Sub ArrayAddItem(arrElements, varElement)
    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)
    arrElements(UBound(arrElements)) = varElement
End Sub

Sub ArrayInsertItem(arrElements, lngIndex, varElement)
    Dim i As Long
    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)
    For i = UBound(arrElements) To lngIndex + 1 Step -1
        arrElements(i) = arrElements(i - 1)
    Next
    arrElements(i) = varElement
End Sub

Function SafeUBound(arrTest)
    On Error Resume Next
    SafeUBound = -1
    SafeUBound = UBound(arrTest)
End Function

Answer 1

您的JSON字符串非常基本。我们可以简单地解析简单的文本函数，而不是使用复杂的对象和集合。

函数extractRates将按原样运行（只需在常量：outputSheet中输入空白工作表的名称。）

Option Explicit

Public Sub extractRates()

    Const url = "https://apilayer.net/api/live?access_key=4429e7caecf213b559496b1548f5" & _
        "f529&currencies=EUR,USD,AUD,BRL,CAD,CNY,CZK,DKK,XCD,EGP,HKD,HUF,INR,JPY,MYR," & _
        "NZD,NOK,PLN,SGD,ZAR,SEK,CHF,THB,TRY,AED,BHD,BBD,IDR,ILS,JMD,JOD,KES,KWD,MUR," & _
        "MAD,OMR,PKR,PHP,QAR,RUB,SAR,KRW,LKR,TWD,TTD,TND,BWP,BGN,CLP,COP,CRC,HRK,DOP,FJD," & _
        "GMD,GTQ,ISK,MXN,RON,VND,PEN,ARS,BAM,BDT,BMD,BND,BOB,BSD,BZD,KYD,LBP,MOP,NAD,NPR," & _
        "RSD,UAH&source=GBP&format=1"
    'alternate url: (much shorter and returns "all 167 from GBP")
    'Const url = "https://apilayer.net/api/live?" & _
        "access_key=4429e7caecf213b559496b1548f5f529&source=GBP&format=1"

    Const stripLeft = """quotes"":{" 'strip everything up to & including this
    Const stripRight = "}" 'strip everything after & including this
    Const outputSheet = "Sheet1" 'output worksheet
    Const rowOffset = 1 'start output on this row

    Dim json As String, json_orig As String, arr, x As Long
    json_orig = getHTTP(url) 'retrieve json
    json = json_orig 'for debugging without reloading

    'strip ends
    x = InStr(json, stripLeft) + Len(stripLeft)
    json = Right(json, Len(json) - x)
    x = InStr(json, stripRight)
    json = Left(json, x - 1)

    'remove whitespace
    json = Application.WorksheetFunction.Trim(json) '(worksheet trim grabs middle blanks)
    json = Replace(json, vbLf, "") 'remove Line Feeds (some API will have vbCR's too)
    json = Replace(json, """", "") 'remove quotation marks
    json = Replace(json, " ", "") 'remove single spaces

    'String is now the string is like: "GBPEUR:1.127663,GBPUSD:1.394759,...": split it by comma
    arr = Split(json, ",")

    'confirm & clear cells
    If MsgBox(UBound(arr) & " quotes found." & vbLf & vbLf & "Worksheet `" & outputSheet & _
        "` will be cleared.", vbOKCancel + vbExclamation, "Delete Existing Data?") <> vbOK Then Exit Sub
    Sheets(outputSheet).Cells.ClearContents

    'dump array into rows
    For x = 0 To UBound(arr) - 1
        Sheets(outputSheet).Range("A" & x + rowOffset) = arr(x)
    Next x

    'text to columns to split on colon
    Sheets(outputSheet).Range("A" & rowOffset & ":A" & x + rowOffset).TextToColumns _
        Destination:=Range("A1"), DataType:=xlDelimited, Other:=True, OtherChar:=":"
    Range("A1").Select
    Debug.Print "Done!"

End Sub

Public Function getHTTP(ByVal url As String) As String
'equivalent to Excel's WEBSERVICE function
    Dim encResp() As Byte, xmlHTTP As Object
    Set xmlHTTP = CreateObject("MSXML2.XMLHTTP") 'create XML/HTTP object
    xmlHTTP.Open "GET", url, False 'initialize GET request
    xmlHTTP.send 'send request to remote server
    encResp = xmlHTTP.responseBody 'receive raw (encoded) response
    Set xmlHTTP = Nothing 'always clean up after yourself!
    getHTTP = StrConv(encResp, vbUnicode) 'return decoded response
End Function

getHTTP就像Excel 2016的WEBSERVICE函数一样：它接受任何URL并返回其背后的代码，无论是HTML，XML，JSON，CSV等......

过程extractRates从json字符串中删除开头和结尾，删除不需要的字符，将其拆分为数组，然后将数组转储到outputSheet TextToColumns完成它的地方

无疑，你可以通过返回＆＃34; all＆＃34;来大大缩短你的网址。费率与this link的国家/地区相比。

_{API文档here。}