VBA: 将选中的单元格区域导出为 JSON 文件

Exploring

发布于 2025-04-17 13:55:11

48800

代码可运行

运行总次数：0

代码可运行

在日常的数据处理中，我们经常会处理表格数据并需要将其导出为标准格式，比如 JSON，方便用于系统对接、前端展示或数据交换。今天我们就用一段简单实用的 VBA 代码，来实现这个功能：将 Excel 中选中的单元格区域导出为 JSON 文件。

🧩 功能概览

这段 VBA 代码的功能如下：

支持选中任意区域（只要第一行为列名，其余为数据）；
将选中区域转为标准 JSON 数组格式；
弹出保存对话框，导出为 .json 文件；
使用 VBA-JSON 模块实现序列化。

✅ 示例数据

转为 JSON 后如下：

[
  {
    "Name": "Tom",
    "Age": 25,
    "City": "Tokyo"
  },
  {
    "Name": "Alice",
    "Age": 30,
    "City": "Osaka"
  }
]

🔧 第一步：准备 JSON 模块

为了支持 JSON 格式，需要引入第三方的 JSON 模块：

下载 JsonConverter.bas
打开 Excel，按下 Alt + F11 进入 VBA 编辑器
菜单栏选择 文件 > 导入文件，导入 JsonConverter.bas

🧑‍💻 第二步：准备 VBA 代码

✳️ JSON 转换函数 `RangeToJson`

Function RangeToJson(dataRange As Range) As String
    Dim headerRange As Range, dataBodyRange As Range
    Dim headers As Object
    Dim r As Range, c As Range
    Dim rowIndex As Long
    Dim jsonObject As Object
    Dim collectionToJson As New Collection

    If dataRange.Rows.Count < 2 Then
        RangeToJson = ""
        MsgBox "选区至少需要包含表头和一行数据。", vbExclamation
        Exit Function
    End If

    Set headerRange = dataRange.Rows(1)
    Set dataBodyRange = dataRange.Resize(dataRange.Rows.Count - 1).Offset(1, 0)

    Set headers = CreateObject("Scripting.Dictionary")
    For Each c In headerRange.Cells
        headers.Add c.Column, CStr(c.Value)
    Next

    For rowIndex = 1 To dataBodyRange.Rows.Count
        Set jsonObject = CreateObject("Scripting.Dictionary")
        For Each c In dataBodyRange.Rows(rowIndex).Cells
            If headers.Exists(c.Column) Then
                jsonObject.Add headers(c.Column), c.Value
            End If
        Next
        collectionToJson.Add jsonObject
    Next

    RangeToJson = JsonConverter.ConvertToJson(collectionToJson, Whitespace:=2)
End Function

✳️ 导出功能 `ExportJsonFromSelectedRange`

Sub ExportJsonFromSelectedRange()
    Dim jsonText As String
    Dim fileSaveName As Variant
    Dim fileNumber As Integer

    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选择一个包含表头的区域。", vbExclamation
        Exit Sub
    End If

    jsonText = RangeToJson(Selection)

    If jsonText = "" Then Exit Sub

    fileSaveName = Application.GetSaveAsFilename(fileFilter:="JSON Files (*.json), *.json")

    If fileSaveName <> False Then
        fileNumber = FreeFile
        Open fileSaveName For Output As fileNumber
        Print #fileNumber, jsonText
        Close fileNumber
        MsgBox "导出成功！"
    End If
End Sub