如何使用VBA处理指定源数据表并生成对应嵌套结构的JSON文件

实现逻辑 #

• 列自动归组：遍历源表表头，根据Prefix1、Prefix2前缀匹配，将同索引的ItemRef、Count、Name自动绑定为一组，支持超过100列的宽表场景
• 条码类型判定：读取ItemRef值，首字符为字母时标记为Pick条码，开头连续N个0时标记为Drop条码，支持重复条码存储
• 层级嵌套组装：将同组的Count、Name作为子节点归入对应ItemRef的层级下，符合要求的嵌套结构
• 双结果输出：同时生成水平结构的结果工作表、导出指定格式的JSON文件到本地

完整VBA代码 #

Sub 生成嵌套JSON()
    Dim srcSheet As Worksheet, outSheet As Worksheet
    Dim lastRow As Long, lastCol As Long, i As Long, j As Long, groupCnt As Long
    Dim jsonStr As String, itemStr As String, refVal As String
    Dim dropZeroCnt As Integer: dropZeroCnt = 3 ' Drop条码判定的开头连续0数量，可自行调整
    
    ' 配置参数，可根据实际修改
    Set srcSheet = ThisWorkbook.Sheets("源数据") ' 源数据表名
    jsonSavePath = ThisWorkbook.Path & "\output.json" ' JSON导出路径
    
    ' 读取源表范围
    lastRow = srcSheet.Cells(Rows.Count, 1).End(xlUp).Row
    lastCol = srcSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    
    ' 生成水平结果表
    On Error Resume Next
    Set outSheet = ThisWorkbook.Sheets("输出结果")
    If Err.Number <> 0 Then Set outSheet = ThisWorkbook.Sheets.Add(, Sheets(Sheets.Count)): outSheet.Name = "输出结果"
    On Error GoTo 0
    outSheet.Cells.Clear
    
    ' 列分组统计
    groupCnt = 0
    For j = 1 To lastCol
        If InStr(srcSheet.Cells(1, j).Value, "ItemRef") > 0 Then groupCnt = groupCnt + 1
    Next j
    
    ' 组装JSON头
    jsonStr = "{""RefInt"":""" & srcSheet.Range("A2").Value & """,""ItemList"":[" ' 假设RefInt在A列，可调整
    
    ' 逐行处理数据
    For i = 2 To lastRow
        itemStr = ""
        For g = 1 To groupCnt
            ' 读取当前组的三个字段，默认按ItemRef/Count/Name连续排列，可修改为前缀匹配逻辑
            refVal = srcSheet.Cells(i, (g - 1) * 3 + 1).Value
            countVal = srcSheet.Cells(i, (g - 1) * 3 + 2).Value
            nameVal = srcSheet.Cells(i, (g - 1) * 3 + 3).Value
            
            ' 判定条码类型
            If refVal Like "[A-Za-z]*" Then
                barType = "Pick"
            ElseIf Left(refVal, dropZeroCnt) = String(dropZeroCnt, "0") Then
                barType = "Drop"
            Else
                barType = "Other"
            End If
            
            ' 组装当前组的JSON节点
            If itemStr <> "" Then itemStr = itemStr & ","
            itemStr = itemStr & "{""Type"":""" & barType & """,""ItemRef"":""" & refVal & """,""Count"":" & countVal & ",""Name"":""" & nameVal & """}"
            
            ' 写入水平结果表
            outSheet.Cells(i - 1, (g - 1) * 4 + 1) = barType
            outSheet.Cells(i - 1, (g - 1) * 4 + 2) = refVal
            outSheet.Cells(i - 1, (g - 1) * 4 + 3) = countVal
            outSheet.Cells(i - 1, (g - 1) * 4 + 4) = nameVal
        Next g
        If i > 2 Then jsonStr = jsonStr & ","
        jsonStr = jsonStr & "{""GroupId"":" & i - 1 & ",""Items"":[" & itemStr & "]}"
    Next i
    
    ' 补全JSON尾
    jsonStr = jsonStr & "]}"
    
    ' 写入JSON文件
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.CreateTextFile(jsonSavePath, True, True)
    ts.Write jsonStr
    ts.Close
    
    ' 输出结果表头
    For g = 1 To groupCnt
        outSheet.Cells(1, (g - 1) * 4 + 1) = "Type_" & g
        outSheet.Cells(1, (g - 1) * 4 + 2) = "ItemRef_" & g
        outSheet.Cells(1, (g - 1) * 4 + 3) = "Count_" & g
        outSheet.Cells(1, (g - 1) * 4 + 4) = "Name_" & g
    Next g
    
    MsgBox "处理完成，结果已保存到输出结果工作表与" & jsonSavePath, vbInformation
End Sub

调整说明 #

• 若源表的列分组规则不是ItemRef/Count/Name连续排列，可修改代码中读取三个字段的列索引匹配逻辑，改为按表头前缀匹配即可
• Drop条码的开头连续0判定数量可修改dropZeroCnt参数的值适配实际规则
• 若RefInt的存储位置不是A列，可修改JSON头组装部分的RefInt取值逻辑

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