我正在尝试将json api转换为excel表。我尝试了不同的解析方法,但目前正在使用VBA-JSON(类似于VB-JSON但解析速度更快)。到目前为止,我将它转换为Object。如果我是正确的话,这是一个集合。但是,将对象转换为表会花费大量时间。
以下是我的代码。在我正在使用的旧机器上,HTTP>字符串使用9s。解析对象需要花费14s。这些是可以接受的,但是循环在集合中经过一列(25k行)成本为30 + s。我需要大约8列从集合中获取,这将花费太长时间。我的i5机器需要一段时间。
Dim ItemCount As Integer
Dim itemID() As Long
Function httpresp(URL As String) As String
Dim x As Object: Set x = CreateObject("MSXML2.XMLHTTP")
x.Open "GET", URL, False
x.send
httpresp = x.responseText
End Function
Private Sub btnLoad_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = false
Dim URL As String: URL = "https://www.gw2shinies.com/api/json/item/tp"
Dim DecJSON As Object: Set DecJSON = JsonConverter.ParseJson(httpresp(URL))
ItemCount = DecJSON.Count
ReDim itemID(1 To ItemCount)
Range("A2:S25000").Clear 'clear range
For i = 1 To ItemCount
Cells(i + 1, 1).Value = DecJSON(i)("item_id")
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
无论如何,我可以从庞大的集合对象中更快地填充excel表吗?
我还检查了Rest to Excel library但是在学习了好几个小时之后我就无法理解......加上我不知道即使我开始工作,它会如何表现。
答案 0 :(得分:6)
考虑下面的例子,有纯VBA JSON解析器。它非常快,但不那么灵活,所以它适合解析只包含类似数据的对象的简单json数组。
Option Explicit
Sub Test()
Dim strJsonString As String
Dim arrResult() As Variant
' download
strJsonString = DownloadJson("https://www.gw2shinies.com/api/json/item/tp")
' 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
对于downolad(大约7 MB)大约需要5秒,对于处理需要10秒,对于我来说需要1.5秒。生成的工作表包含23694行,包括表头:
答案 1 :(得分:1)
您是否曾尝试通过vba-web toolkit(来自制作vba-json的人)调用网络服务?它会自动将JSON结果包装到数据对象中。
然后我创建了一个Function,它将一个简单的类似JSON的表转换为一个2D数组,然后我将其粘贴到一个Range中。
首先,这是您可以添加到代码中的功能:
' Converts a simple JSON dictionary into an array
Function ConvertSimpleJsonToArray(data As Variant, ParamArray columnDefinitionsArray() As Variant) As Variant
Dim NumRows, NumColumns As Long
NumRows = data.Count
NumColumns = UBound(columnDefinitionsArray) - LBound(columnDefinitionsArray) + 1
Dim ResultArray() As Variant
ReDim ResultArray(0 To NumRows, 0 To (NumColumns - 1)) 'Rows need an extra header row but columns do not
Dim x, y As Integer
'Column headers
For y = LBound(columnDefinitionsArray) To UBound(columnDefinitionsArray)
ResultArray(LBound(ResultArray), y) = columnDefinitionsArray(y)
Next
'Data rows
For x = 1 To NumRows
For y = LBound(columnDefinitionsArray) To UBound(columnDefinitionsArray)
ResultArray(x, y) = data(x)(columnDefinitionsArray(y))
Next
Next
ConvertSimpleJsonToArray = ResultArray
End Function
以下是我尝试调用您的API并在Excel中仅填充4列的方法:
Sub Auto_Open()
Dim FocusClient As New WebClient
FocusClient.BaseUrl = "https://www.gw2shinies.com/api"
' Use GetJSON helper to execute simple request and work with response
Dim Resource As String
Dim Response As WebResponse
'Create a Request and get Response
Resource = "json/item/tp"
Set Response = FocusClient.GetJson(Resource)
If Response.StatusCode = WebStatusCode.Ok Then
Dim ResultArray() As Variant
ResultArray = ConvertSimpleJsonToArray(Response.data, "item_id", "name", "type", "subtype")
Dim NumRows, NumColumns As Long
NumRows = UBound(ResultArray) - LBound(ResultArray) + 1
NumColumns = UBound(ResultArray, 2) - LBound(ResultArray, 2) + 1
ActiveSheet.Range("a1").Resize(NumRows, NumColumns).Value = ResultArray
Else
Debug.Print "Error: " & Response.Content
End If
End Sub
是的,它确实需要几秒钟才能运行,但这更可能是您拥有的26000行。即使在Chrome中加载原始JSON也需要几秒钟,这需要JSON解析并在其上加载到数组中。您可以在每个代码块之后按Debug.Print
个时间戳对代码进行基准测试。
我希望有所帮助!
答案 2 :(得分:0)
一次写入所有值然后逐个单元地执行它会更快。此外,您可能会触发辅助事件,因此禁用事件可能有助于提高性能。如果下面的代码性能仍然很差,问题在于JsonConverter的性能。
Dim ItemCount As Integer
Dim items() As Variant
Function httpresp(URL As String) As String
Dim x As Object: Set x = CreateObject("MSXML2.XMLHTTP")
x.Open "GET", URL, False
x.send
httpresp = x.responseText
End Function
Private Sub btnLoad_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim URL As String: URL = "https://www.gw2shinies.com/api/json/item/tp"
Dim DecJSON As Object: Set DecJSON = JsonConverter.ParseJson(httpresp(URL))
ItemCount = DecJSON.Count
ReDim items(1 To ItemCount, 1 To 1)
Range("A2:S25000").Clear 'clear range
Dim test As Variant
For i = 1 To ItemCount
items(i, 1) = DecJSON(i)("item_id")
'Cells(i + 1, 1).Value = DecJSON(i)("item_id")
Next i
Range(Range("A2"), Range("A2").Offset(ItemCount)).Value = items
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub