VBA将解析后的JSON对象数据写入Excel工作表的实现与优化

你当前逐单元格赋值的写法存在两个核心问题：一是逐单元格和工作表交互的效率极低，数据量稍大就会出现明显卡顿；二是手动用Split拆分JSON响应字符串的逻辑非常脆弱，只要接口返回内容里包含},字符、或者JSON结构稍有嵌套就会出现解析错误。
下面是规范化的实现思路和优化后代码：

核心优化原则 #

• 放弃手动拆分JSON：JsonConverter本身支持直接解析完整接口响应，不需要手动切割字符串补全格式，从根源避免解析异常
• 内存数组批量写入：所有解析完成的数据先存入VBA内存的二维数组，最后一次性写入工作表，写入效率相比逐单元格赋值可提升百倍以上
• 配置化字段映射：将需要导出的字段和列顺序统一配置，后续调整字段、增减列不需要修改大段重复赋值代码
• 原生适配结构化表格：直接操作Excel的ListObject（结构化表）对象，不需要手动计算行号，自动继承表格格式、筛选规则
• 强制显式声明变量：避免隐式类型转换、变量名拼写错误导致的隐性bug
• 完善的错误处理：代码异常时自动恢复Excel默认设置，不会出现程序卡死后屏幕刷新、自动计算被关闭的问题

优化后完整代码 #

首先需要在VBA模块的最顶部添加Option Explicit语句，强制所有变量必须显式声明：

Option Explicit

Sub ImportApiDataToSheet()
    ' 变量声明时明确指定类型
    Dim objRequest As Object
    Dim strUrl As String
    Dim blnAsync As Boolean
    Dim strResponse As String
    Dim totalPage As Long
    Dim perPage As Long
    Dim currentPage As Long
    Dim jsonParsed As Object
    Dim dataCollection As Object
    Dim jsonRow As Object
    Dim outputArr() As Variant
    Dim fieldMap As Variant
    Dim rowIndex As Long
    Dim colIndex As Long
    Dim ws As Worksheet
    Dim targetTable As ListObject
    
    ' --------------------------
    ' 配置项 按需修改
    ' --------------------------
    totalPage = 3
    perPage = 100 ' 替换为你接口实际的每页条数
    blnAsync = False
    Set ws = ThisWorkbook.Worksheets("数据") ' 替换为你要输出的工作表名称
    ' 字段按列顺序排列，后续增减字段、调整列序只需要修改这里
    fieldMap = Array("numero_commessa", "stato", "tiratura", "isbn", "gredit", "title", "dtcreate", "type", "dtcons")

    ' 临时关闭Excel功能提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error GoTo ErrorHandler

    ' 初始化目标结构化表格
    On Error Resume Next
    Set targetTable = ws.ListObjects("订单表") ' 替换为你的结构化表格名称
    On Error GoTo ErrorHandler
    ' 表格不存在则自动创建
    If targetTable Is Nothing Then
        For colIndex = 0 To UBound(fieldMap)
            ws.Cells(1, colIndex + 1).Value = fieldMap(colIndex)
        Next
        Set targetTable = ws.ListObjects.Add(xlSrcRange, ws.Range("A1").Resize(1, UBound(fieldMap) + 1), , xlYes)
        targetTable.Name = "订单表"
    End If

    ' 初始化内存数组，提前预留足够容量
    ReDim outputArr(1 To totalPage * perPage, 1 To UBound(fieldMap) + 1)
    rowIndex = 1

    ' 分页拉取接口数据
    For currentPage = 1 To totalPage
        Set objRequest = CreateObject("MSXML2.XMLHTTP.6.0") ' 使用更稳定的6.0版本
        strUrl = "https://你的接口地址?page=" & currentPage & "&per_page=" & perPage ' 拼接分页参数

        With objRequest
            .Open "GET", strUrl, blnAsync
            .SetRequestHeader "oauth-token", "你的token值"
            .SetRequestHeader "hostname", "你的hostname值"
            .SetRequestHeader "x-client-domain", "你的域名值"
            .SetRequestHeader "Content-Type", "application/json"
            .Send

            If blnAsync Then
                While .readyState <> 4
                    DoEvents
                Wend
            End If
            strResponse = .ResponseText
        End With

        ' 直接解析完整响应，不需要手动拆分字符串
        Set jsonParsed = JsonConverter.ParseJson(strResponse)
        Set dataCollection = jsonParsed("data") ' 直接读取data节点下的所有记录集合

        ' 遍历记录写入内存数组，全程不操作工作表
        For Each jsonRow In dataCollection
            For colIndex = 0 To UBound(fieldMap)
                ' 兼容字段缺失的情况，避免运行报错
                outputArr(rowIndex, colIndex + 1) = IIf(jsonRow.Exists(fieldMap(colIndex)), jsonRow(fieldMap(colIndex)), "")
            Next
            rowIndex = rowIndex + 1
        Next

        ' 释放当前页对象
        Set objRequest = Nothing
        Set jsonParsed = Nothing
        Set dataCollection = Nothing
    Next

    ' 调整数组到实际数据行数
    ReDim Preserve outputArr(1 To rowIndex - 1, 1 To UBound(fieldMap) + 1)

    ' 批量写入结构化表格
    If targetTable.ListRows.Count > 0 Then targetTable.DataBodyRange.Delete
    targetTable.Resize targetTable.Range.Resize(rowIndex, UBound(fieldMap) + 1)
    targetTable.DataBodyRange.Value = outputArr
    ' ISBN列设置为文本格式，避免长数字转科学计数法丢精度
    targetTable.ListColumns("isbn").Range.NumberFormat = "@"

    MsgBox "导入完成，共导入 " & rowIndex - 1 & " 条记录", vbInformation

ExitSub:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

ErrorHandler:
    MsgBox "导入出错：" & Err.Description, vbCritical
    Resume ExitSub
End Sub

关键优化点说明 #

• 移除了所有手动拆分、替换JSON字符串的逻辑，直接通过JsonConverter解析完整响应后取data节点的集合，只要接口返回标准JSON格式就不会出现解析错误
• 所有数据解析过程都在内存中完成，循环过程中没有任何单元格读写操作，最后一次性写入，万条级别的数据也可以在1秒内完成写入
• 字段映射统一配置，后续需要新增导出字段、调整列顺序时，只需要修改fieldMap数组即可，不需要重复写单元格赋值代码
• 自动适配结构化表格，不需要手动维护行号计数器Counter，表格会自动扩展范围、应用预设格式
• 修正了原代码中的变量类型错误：比如页码、条数这类数值型变量原来声明为String类型，容易出现类型不匹配的问题
• 增加了容错处理：接口返回字段缺失时不会直接中断运行，代码出错时会自动恢复Excel的屏幕刷新、自动计算设置，不会导致Excel界面卡死
• 显式使用MSXML2.XMLHTTP.6.0版本，相比旧版本兼容性、稳定性更好

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