大規模なコレクションオブジェクト（jsonから解析された）を書き出して範囲を広げる

Question

json apiをExcelテーブルに変換しようとしています。私はさまざまな解析方法を試しましたが、現在はVBA-JSON（VB-JSONに似ていますが、より高速な解析）を使用しています。これまではObjectに変換することができました。私が正しいなら、それはコレクションです。しかし、オブジェクトをテーブルに変換するには膨大な時間がかかります。

以下は私のコードです。私が使用しているこの古いマシンでは、HTTP>文字列は9を使用します。オブジェクトを解析するには14秒かかります。これらは許容されますが、コレクションの1列（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 to Excel libraryをチェックしましたが、何時間も勉強しても理解できません。また、うまく動作してもわかりません。

Answer 1

次の例を考えてみましょう。純粋な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 

それは（約7 MB）をdownolad約5秒かかり、処理および私のために出力のために1.5のための10秒。結果のワークシートは、テーブルのヘッダーを含む23694行含まれています：あなたは（VBA-JSONを作った同じ人から）vba-web toolkitを経由してWebサービスを呼び出す

Answer 2

すべての値を一度に書き込んでから、セルごとに行う方が速いです。また、セカンダリイベントの発動もありますので、イベントを無効にするとパフォーマンスが向上します。以下のコードでパフォーマンスがまだ悪い場合は、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 

Answer 3

しようとしたことがありますか？自動的にJSON結果をデータオブジェクトにラップします。

次に、テーブルのような単純な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行に多いだろう。生のJSONをChromeに読み込むにも数秒かかりましたが、これでJSONの解析とその上の配列への読み込みが行われました。各コードブロックの後にコードをDebug.Printタイムスタンプでベンチマークすることができます。

私はそれが助けてくれることを願っています！