如何优化VBA解析JSON的速度？现有代码加载超20秒

问题描述 #

我有一段调用Rest API拉取JSON数据的VBA代码，该JSON包含约1000条记录、每条50个字段。代码可正常运行，但加载耗时超20秒，这类接口我共需调用6个。我使用的是VBA-JSON v2.3.1（Tim Hall开发），请问是否有更快的实现方式？

原代码 #

base_url = "https://api.servicem8.com/api_1.0/"

endpoint = "category.json """

url = base_url & endpoint

Set xmlhttp = CreateObject("MSXML2.XMLHTTP")

xmlhttp.Open "GET", url, False, M8Username, M8Password

xmlhttp.Send

If xmlhttp.Status = 200 Then

    Set jsontext = JsonConverter.ParseJson(xmlhttp.ResponseText)
    
Ws2.Rows.ClearContents

    For Each Collect In jsontext
        With Ws2
            For Each key In Collect.Keys
            On Error Resume Next
                .Cells(1, k).value = key
                .Cells(j, k).value = Collect.Item(key)
                k = k + 1
            Next key
            k = 1
            j = j + 1
        End With
    Next Collect
    j = 2
    k = 1
    
Else
    Debug.Print "An error occurred:" & xmlhttp.Status
    Exit Sub
End If

Set xmlhttp = Nothing

示例JSON记录 #

{"uuid":"00000000-0000-0000-0000-000000000000","active":1,"date":"0000-00-00 00:00:00","job_address":"AAAAAA,\nAAAAA, AA 00000","billing_address":"0000 AAAAA\nAAAAA, AA 00000","status":"Quote","quote_date":"0000-00-00 00:00:00","work_order_date":"0000-00-00 00:00:00","work_done_description":"","generated_job_id":"6679","completion_date":"0000-00-00 00:00:00","completion_actioned_by_uuid":"","unsuccessful_date":"0000-00-00 00:00:00","payment_date":"0000-00-00 00:00:00","payment_method":"","payment_amount":0,"payment_actioned_by_uuid":"","edit_date":"0000-00-00 00:00:00","payment_note":"","ready_to_invoice":"0","ready_to_invoice_stamp":"0000-00-00 00:00:00","company_uuid":"00000000-0000-0000-0000-000000000000","geo_is_valid":1,"lng":-00.0000000,"lat":00.0000000,"geo_country":"United States","geo_postcode":"00000","geo_state":"AA","geo_city":"AAAAAAAAAA","geo_street":"AAAAA","geo_number":"0000","payment_processed":0,"payment_processed_stamp":"0000-00-00 00:00:00","payment_received":1,"payment_received_stamp":"0000-00-00 00:00:00","total_invoice_amount":"0.0000","job_is_scheduled_until_stamp":"0000-00-00 00:00:00","category_uuid":"00000000-0000-0000-0000-000000000000","queue_uuid":"00000000-0000-0000-0000-000000000000","queue_expiry_date":"0000-00-00 00:00:00","badges":"[\"00000000-0000-0000-0000-000000000001\",\"00000000-0000-0000-0000-000000000002\",\"00000000-0000-0000-0000-000000000003\"]","invoice_sent":false,"purchase_order_number":"","invoice_sent_stamp":"0000-00-00 00:00:00","queue_assigned_staff_uuid":"","quote_sent_stamp":"0000-00-00 00:00:00","quote_sent":false,"active_network_request_uuid":"","related_knowledge_articles":false,"job_description":"AA AAAA AAAAAAAAA AAAAAAA","created_by_staff_uuid":"00000000-0000-0000-0000-000000000000"}

优化方案及代码 #

核心优化点 #

• 批量写入单元格：避免逐单元格赋值，先将数据存入二维数组，最后一次性写入工作表，这是提升速度的关键。
• 关闭Excel界面刷新：操作工作表前关闭ScreenUpdating和EnableEvents，减少界面渲染开销。
• 只提取一次表头：第一条记录的字段名就是所有表头，无需每次循环都写入。
• 清理冗余错误处理：On Error Resume Next会掩盖问题，建议仅在必要时使用或明确处理错误。

优化后的代码 #

Sub FetchAndLoadJSON()
    Dim base_url As String, endpoint As String, url As String
    Dim xmlhttp As Object
    Dim jsontext As Object, collect As Object
    Dim headers As Variant, dataArr As Variant
    Dim rowNum As Long, colNum As Long, i As Long, j As Long
    
    ' 初始化参数，修正原代码中endpoint的多余引号
    base_url = "https://api.servicem8.com/api_1.0/"
    endpoint = "category.json"
    url = base_url & endpoint
    
    ' 发送API请求
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    xmlhttp.Open "GET", url, False, M8Username, M8Password
    xmlhttp.Send
    
    If xmlhttp.Status <> 200 Then
        Debug.Print "请求错误：" & xmlhttp.Status
        Set xmlhttp = Nothing
        Exit Sub
    End If
    
    ' 解析JSON
    Set jsontext = JsonConverter.ParseJson(xmlhttp.ResponseText)
    Set xmlhttp = Nothing
    
    ' 准备数据容器
    rowNum = jsontext.Count
    colNum = jsontext(1).Count
    ReDim headers(1 To colNum)
    ReDim dataArr(1 To rowNum, 1 To colNum)
    
    ' 提取表头
    j = 1
    For Each key In jsontext(1).Keys
        headers(j) = key
        j = j + 1
    Next key
    
    ' 提取数据到数组
    i = 1
    For Each collect In jsontext
        j = 1
        For Each key In collect.Keys
            dataArr(i, j) = collect(key)
            j = j + 1
        Next key
        i = i + 1
    Next collect
    
    ' 写入工作表，关闭刷新提升速度
    With Ws2
        .EnableEvents = False
        .ScreenUpdating = False
        .Rows.ClearContents
        
        ' 写入表头
        .Range(.Cells(1, 1), .Cells(1, colNum)).Value = headers
        ' 写入数据
        .Range(.Cells(2, 1), .Cells(rowNum + 1, colNum)).Value = dataArr
        
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set jsontext = Nothing
End Sub

额外优化建议 #

• 异步请求并行调用：如果需要调用多个接口，可以改用异步XMLHTTP请求，同时发起多个请求，减少总等待时间，但需要处理回调逻辑。
• API分页：如果接口支持分页，每次拉取部分数据（比如200条），分多次请求，避免单次处理过大的JSON数据。
• 缓存重复数据：如果多个接口返回重复字段或数据，可缓存这些内容，避免重复解析和写入。

内容的提问来源于stack exchange，提问作者Hareborn