在 Excel 上解析 JSON (2003-2013)
Parse JSON on Excel (2003-2013)
我目前正在尝试从 link 获取可刷新的 JSON 提要到 Excel。我遇到了帮助我处理另一个 的代码，但是当 运行 时，它会生成错误
Run-time error '-2147467259 (80004005)': Unspecified error) on
"strMarkerQuot = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)".
我能否获得有关按原样执行此代码或解析或提取单元格数据的任何其他方法的帮助（到目前为止，我只能设法将完整的 JSON 写入单元格）
如果需要，这是 link 到 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¤cies=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
您的 JSON 字符串非常基础。与其使用复杂的对象和集合，我们可以将其解析为简单的文本函数。
函数extractRates将运行as-is（只需在常量中输入空白工作表的名称：outputSheet）。
Option Explicit
Public Sub extractRates()
Const url = "https://apilayer.net/api/live?access_key=4429e7caecf213b559496b1548f5" & _
"f529¤cies=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 和 returns 背后的代码，无论 HTML 、XML、JSON、CSV 等...
过程 extractRates 从 json 字符串中剥离开头和结尾，删除不需要的字符，将其拆分为一个数组，并将数组转储到 outputSheet 中，其中 TextToColumns 完成。
顺便说一句，与 this link.
的国家/地区相比，您可以通过返回 "all" 比率来大大缩短 URL
API 文档 here.
我目前正在尝试从 link 获取可刷新的 JSON 提要到 Excel。我遇到了帮助我处理另一个
Run-time error '-2147467259 (80004005)': Unspecified error) on
"strMarkerQuot = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)".
我能否获得有关按原样执行此代码或解析或提取单元格数据的任何其他方法的帮助（到目前为止，我只能设法将完整的 JSON 写入单元格）
如果需要，这是 link 到 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¤cies=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
您的 JSON 字符串非常基础。与其使用复杂的对象和集合，我们可以将其解析为简单的文本函数。
函数extractRates将运行as-is（只需在常量中输入空白工作表的名称：outputSheet）。
Option Explicit
Public Sub extractRates()
Const url = "https://apilayer.net/api/live?access_key=4429e7caecf213b559496b1548f5" & _
"f529¤cies=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 和 returns 背后的代码，无论 HTML 、XML、JSON、CSV 等...
过程 extractRates 从 json 字符串中剥离开头和结尾，删除不需要的字符，将其拆分为一个数组，并将数组转储到 outputSheet 中，其中 TextToColumns 完成。
顺便说一句，与 this link.
的国家/地区相比，您可以通过返回 "all" 比率来大大缩短 URLAPI 文档 here.