VBA求助：修改Excel转JSON代码实现无表格依赖、垂直排版输出

现存问题 #

现有Excel导出JSON的VBA代码可覆盖大部分基础需求，但存在两个核心缺陷：

• 必须将工作表转换为结构化表格才能运行，无法直接读取指定单元格范围
• 输出JSON为单条数据横向拼接格式，无缩进换行，可读性极差

需求说明 #

• 移除对结构化表格的依赖，支持直接转换指定单元格范围，默认取范围第一行（A1、B1……）作为字段表头
• 调整JSON输出格式，每个键值对单独占行，按表头字段顺序逐行展示，单条数据对象输出完成后再输出下一条，增加缩进提升可读性

原有VBA代码（绑定export_in_json_format_Click点击事件） #

Private Sub export_in_json_format_Click()

    Dim fs As Object

    Dim jsonfile
    Dim rangetoexport As Range
    Dim rowcounter As Long
    Dim columncounter As Long
    Dim linedata As String
   
    ' change range here
    Set rangetoexport = Sheet1.Range("A1:J58")
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    ' change dir here
   
    Set jsonfile = fs.CreateTextFile("Desktop" & "Testr.json", True)
   
    linedata = "{""Output"": ["
    jsonfile.WriteLine linedata
    For rowcounter = 2 To rangetoexport.Rows.Count
        linedata = ""
        For columncounter = 1 To rangetoexport.Columns.Count
            linedata = linedata & """" & rangetoexport.Cells(1, columncounter) & """" & ":" & """" & rangetoexport.Cells(rowcounter, columncounter) & """" & ","
        Next
        linedata = Left(linedata, Len(linedata) - 1)
        If rowcounter = rangetoexport.Rows.Count Then
            linedata = "{" & linedata & "}"
        Else
            linedata = "{" & linedata & "},"
        End If
       
        jsonfile.WriteLine linedata
    Next
    linedata = "]}"
    jsonfile.WriteLine linedata
    jsonfile.Close

    Set fs = Nothing

End Sub

原有代码输出格式：单条数据所有键值对横向拼接为单行，样式为{"ID":"值","Name":"值","Price":"值"……}，阅读和修改成本高。

修正后可直接运行的代码 #

修正内容：

• 移除结构化表格依赖，直接读取指定Range范围的单元格内容，自动识别范围第一行为表头
• 增加层级缩进，每个键值对单独占行，JSON结构清晰
• 修复原有代码路径拼接错误，自动定位当前用户桌面路径作为文件输出位置，避免找不到生成文件的问题
• 增加空行跳过逻辑，范围内的空行不会生成无效JSON节点

Private Sub export_in_json_format_Click()
    Dim fs As Object
    Dim jsonfile
    Dim rangetoexport As Range
    Dim rowcounter As Long
    Dim columncounter As Long
    Dim linedata As String
    Dim desktopPath As String
    
    ' 配置项：指定需要导出的单元格范围
    Set rangetoexport = Sheet1.Range("A1:J58")
    ' 自动获取当前系统桌面路径
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    ' 在桌面生成Testr.json文件，参数True表示覆盖已有同名文件
    Set jsonfile = fs.CreateTextFile(desktopPath & "Testr.json", True, True)
    
    ' 写入JSON根节点起始
    jsonfile.WriteLine "{""Output"": ["
    
    ' 从第二行开始遍历数据行，第一行固定为表头
    For rowcounter = 2 To rangetoexport.Rows.Count
        ' 第一列为空则判定为空行，跳过生成
        If rangetoexport.Cells(rowcounter, 1) <> "" Then
            jsonfile.WriteLine "  {"
            ' 逐列遍历字段，每个键值对单独占行
            For columncounter = 1 To rangetoexport.Columns.Count
                linedata = "    """ & rangetoexport.Cells(1, columncounter) & """: """ & rangetoexport.Cells(rowcounter, columncounter) & """"
                ' 非最后一列字段末尾加逗号
                If columncounter < rangetoexport.Columns.Count Then
                    linedata = linedata & ","
                End If
                jsonfile.WriteLine linedata
            Next
            ' 写入单条数据对象结尾，非最后一条数据末尾加逗号
            If rowcounter = rangetoexport.Rows.Count Or rangetoexport.Cells(rowcounter + 1, 1) = "" Then
                jsonfile.WriteLine "  }"
            Else
                jsonfile.WriteLine "  },"
            End If
        End If
    Next
    
    ' 写入JSON根节点结尾
    jsonfile.WriteLine "]}"
    jsonfile.Close
    Set fs = Nothing
    
    MsgBox "JSON文件已成功导出到桌面", vbInformation
End Sub

导出效果示例 #

修正后导出的JSON格式如下：

{"Output": [
  {
    "ID": "1",
    "Name": "示例商品1",
    "Price": "29.9",
    "Quantity": "120"
  },
  {
    "ID": "2",
    "Name": "示例商品2",
    "Price": "49.9",
    "Quantity": "85"
  }
]}

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