将大集合对象（从jsonparsing）写入excel范围
我正在尝试将json api转换为excel表格。 我尝试了不同的parsing方法，但目前使用VBA-JSON （类似于VB-JSON，但更快的parsing）。 到目前为止，我把它转换成一个对象。 这是一个集合，如果我是正确的。 但是，将对象转换为表需要花费大量的时间。
以下是我的代码。 在我使用的这台旧机器上，HTTP>string使用9。 parsing到对象的成本为14s。 这些是可以接受的，但是通过一个列（25k行）的for循环花费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到Excel库，但是在学习了几个小时之后我就不明白了……再加上我不知道我是否能够正常工作，它将如何工作。
考虑下面的例子，有纯粹的VBA JSONparsing器。 这是相当快的，但不是那么灵活，所以它适合于parsing简单的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行，包括表头：
你有没有尝试通过vba-web工具包 （来自vba-json的同一个人）调用web服务？ 它会自动将JSON结果包装到数据对象中。
然后我创build了一个函数，将一个简单的表格式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也花费了几秒钟的时间，并且已经将JSONparsing并加载到数组中。 您可以在每个代码块之后通过Debug.Print时间戳对代码进行基准testing。
我希望有帮助！
一次写入所有的值，然后逐个单元地写入，会更快。 你也可能有次要事件发生，所以禁用事件可能有助于性能。 如果下面的代码性能仍然差，问题是与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