Scrive un oggetto di raccolta di grandi dimensioni (analizzato da json) nell'intervallo di Excel

Question

Sto provando a convertire un json api in una tabella di Excel. Ho provato diversi metodi di analisi ma attualmente utilizzo VBA-JSON (simile a VB-JSON ma analisi più veloce). Finora l'ho ottenuto per convertire in un oggetto. È una collezione se ho ragione. Tuttavia, convertire l'oggetto in una tabella richiede un'enorme quantità di tempo.

Quanto segue è il mio codice. Su questa vecchia macchina che sto usando, la stringa HTTP> usa 9s. La ricerca nell'oggetto costa 14s. Questi sono accettabili ma il ciclo for per attraversare una colonna (25k righe) nella raccolta costa 30 + s. Ho bisogno di circa 8 colonne per ottenere dalla raccolta e ciò richiederebbe troppo tempo. E ci vuole altrettanto tempo nella mia macchina 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 

Esiste comunque la possibilità di popolare il tavolo excel più rapidamente dall'enorme oggetto di raccolta?

Ho anche controllato Rest to Excel library ma non riesco a capirlo dopo aver studiato per ore ...... in più non so nemmeno se riuscissi a farlo funzionare, come funzionerebbe.

Answer 1

Si consideri l'esempio di seguito, c'è puro parser VBA JSON. È abbastanza veloce, ma non così flessibile, quindi è adatto per l'analisi di semplici array JSON di oggetti contenenti solo dati simili a tabelle.

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 

ci vogliono circa 5 secondi per downolad (circa. 7 MB), 10 secondi per l'elaborazione e 1,5 per l'uscita per me. Il foglio di lavoro risultante contiene 23694 righe tra cui intestazione della tabella:

Answer 2

È più veloce scrivere tutti i valori contemporaneamente per eseguirlo cella per cella. Inoltre è possibile che l'evento secondario venga attivato in modo che gli eventi di disabilitazione possano aiutare con le prestazioni. Se le prestazioni sono ancora scadenti con il codice riportato di seguito, il problema riguarda le prestazioni di 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

Avete provato a chiamare il servizio Web tramite il vba-web toolkit (dalle stesse persone che hanno fatto VBA-JSON)? Incapsula automaticamente il risultato JSON in un oggetto dati.

Ho quindi creato una funzione che converte un semplice JSON simile a una tabella in un array 2D, che quindi lo incollo in un intervallo.

In primo luogo, ecco la funzione è possibile aggiungere al codice:

' 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 

Ecco come ho provato a chiamare la vostra API e popolando soli 4 colonne in Excel:

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 

Sì ci vuole un pochi secondi per l'esecuzione, ma questo è più probabile per le 26000 file che hai. Persino il caricamento del raw JSON in Chrome ha richiesto alcuni secondi e questo ha analizzato JSON e caricato in array su di esso. È possibile eseguire il benchmark del codice tramite i timestamp Debug.Print dopo ciascun blocco di codice.

Spero che questo aiuti!