ADODB.Stream创建UTF-8+BOM编码的文本文件。

 
然后遍历数据区，格式化数据，输出即可。

 
小数据还行，大数据没测试。

 
另，使用fso创建的文本文件编码为ANSI，ajax解析json时出现乱码无法正常解析。
 

 
 

 
 
 
 
 Sub 
  ToJson() 
 '创建UTF8文本文件
 
 
  
 myrange = Worksheets(
 "sheet1"
 ).UsedRange  
 '通过有效数据区来选择数据
 
 
  
 'myrange = ActiveWorkbook.Names("schoolinfo").RefersToRange '通过定义的名称来选择数据
 
 
  
 'myrange = Range(Worksheets("sheet1").Range("a1").End(xlDown), Worksheets("sheet1").Range("a1").End(xlToRight)) '通过标题行的最大行最大列来选择数据
 

   
 
 
 Total = UBound(myrange, 1) 
 '获取行数
 
 
 Fields = UBound(myrange, 2) 
 '获取列数
 

   
 
 
      
 Dim 
  objStream 
 As 
  Object
 
 
      
 Set 
  objStream = CreateObject(
 "ADODB.Stream"
 )
 
 
       
 
 
      
 With 
  objStream
 
 
             
 .Type = 2
 
 
             
 .Charset = 
 "UTF-8"
 
 
             
 .Open
 
 
             
 .WriteText 
 "{"
 "total"
 ":" 
  & Total & 
 ","
 "contents"
 ":["
 
 
      
 
 
             
 For 
  i = 2 
 To 
  Total
 
 
                 
 .WriteText 
 "{"
 
 
                 
 For 
  j = 1 
 To 
  Fields
 
 
                     
 .WriteText 
 ""
 "" 
  & myrange(1, j) & 
 ""
 ":"
 "" 
  & Replace(myrange(i, j), 
 ""
 ""
 , 
 "\""
 ") & "
 ""
 "
 
 
                      
 If 
  j <> Fields 
 Then
 
 
                         
 .WriteText 
 ","
 
 
                      
 End 
  If
 
 
                 
 Next
 
 
                 
 If 
  i = Total 
 Then
 
 
                         
 .WriteText 
 "}"
 
 
                 
 Else
 
 
                         
 .WriteText 
 "},"
 
 
                 
 End 
  If
 
 
             
 Next
 

   
 
 
             
 .WriteText 
 "]}"
 
 
             
 .SaveToFile ActiveWorkbook.FullName & 
 ".json"
 , 2
 
 
      
 End 
  With
 
 
      
 Set 
  objStream = 
 Nothing
 
 
 End 
  Sub
 

 

什么是JSON?
 
JSON(JavaScript Object Notation) 是一种及其轻量级的数据交换格式，它是 ECMAScript (欧洲计算机协会制定的JavaScript规范)的一个子集，它使用完全独立于任何编程语言的文本格式来表示数据。
 由于JSON天然具备了简洁和清晰的层次结构，易于机器解析和生成，从2005年前后开始JSON成为主流的网络数据传输格式。进行网页数据抓取的时候，很多页面请求的返回结果都是JSON格式的。
 详细的JSON标准规范请参考：
 
 
 
http://json.com/specs/
 
 
JSON是什么样的？
 
JSON 本质是一个字符串（由花括号{}包裹起来），它是JavaScript对象的字符串表示法。例如：
 
 
 
{“applySn”: “粤G妆网备字2017050113”, “applySnTT”: “”, “apply_enter_address”: “”, “enterpriseName”: “广州市金日精细化工有限公司”, “enterpriseNameTT”: “”, “is_off”: “N”, “newProcessid”: “20170421153208vq3fu”, “off_date”: “”, “org_name”: “”, “processid”: “20170421153208vq3fu”, “productName”: “悠莅雅柔美亮肤按摩霜”, “productNameTT”: “”, “provinceConfirm”: “2017-05-17”}
 
 
如何解读JSON？
 
据说JSON易于人阅读和编写，我怎么看出来，只看到一堆字符，完全不知道包含什么信息。那么来看看下面这段JSON，是不是顿时觉得清爽了很多，其实内容和上一段完全相同，只是进行了相应的格式化显示。
 
{
      "applySn": "粤G妆网备字2017050113",
      "applySnTT": "",
      "apply_enter_address": "",
      "enterpriseName": "广州市金日精细化工有限公司",
      "enterpriseNameTT": "",
      "is_off": "N",
      "newProcessid": "20170421153208vq3fu",
      "off_date": "",
      "org_name": "",
      "processid": "20170421153208vq3fu",
      "productName": "悠莅雅柔美亮肤按摩霜",
      "productNameTT": "",
      "provinceConfirm": "2017-05-17"
}
 
KEY和VALUE都由半角双引号包裹，二者之间由冒号做为间隔（冒号之后可能有空格），也就是如下格式，类似于VBA中字典对象。
 
"KEY": "VALUE"
 
例如：provinceConfirm的VALUE为2017-05-17，不难看出此部分数据包含13组KEY和VALUE。
 有很多在线工具可以帮助我们实现JSON的格式转换，这是编程过程中一个非常重要的工具。例如：
 
 
 
http://jsonviewer.stack.hu/
 
 
除了转换为上面的格式外，还可以转换为表格格式，如下图，有些Excel单元格的味道了。
 
 
VBA解析JSON
 
非常可惜的是VB流行的年代JSON没出现，所以VBA也不支持JSON对象。但是既然JSON数据本质是一个字符串，VBA中丰富的字符串处理函数应该也可以胜任解析JSON这个工作。下面就以上面的JSON数据为例，演示如何在VBA中进行解析。
 
Sub JSON_Split()
    Dim Res(100, 1 To 2)
    Dim objRegEx As Object
    Dim iRow, myStr, arrLine, arrItem
    myStr = Trim([A1].Value)
    Range("A3:B3").Value = Array("Key", "Value")
    myStr = Replace(myStr, """", "")
    myStr = Replace(myStr, " ", "")
    arrLine = Split(Mid(myStr, 2, Len(myStr) - 2), ",")
    iRow = 4
    For i = LBound(arrLine) To UBound(arrLine)
        arrItem = Split(Trim(arrLine(i)), ":")
        Cells(iRow, 1).Resize(1, 2).Value = arrItem
        iRow = iRow + 1
    Next
End Sub
 
代码解析
 第5行代码读取保存在工作表A1单元格的JSON字符串。
 第6行代码写入第3行的表头。
 由于KEY和VALUE中没有空格个引号，因此第7行和第8行代码去除JSON字符串中的引号和空格，便于后续拆分。
 第9行使用对号做为分隔符，把JSON字符串进行拆分，结果为"KEY":"VALUE"形式。其中MID函数是为了去除字符串首尾的花括号。
 第12行代码冒号做为分隔符再次拆分。
 第13行代码将结果写入相应行的单元格中。
 
运行示例代码，结果如下，妥妥的写入了我们熟悉的单元格，可以很方便使用这些数据了。
 
 
JSON中一个KEY也可以对应多个VALUE，对于这类数据，需要再多使用一次SPLIT函数进行拆分。
 
 
相关博文链接：
 VBA解析JSON数据（1）-- Split函数
 VBA解析JSON数据（2）–正则表达式
 VBA解析JSON数据（3）–JavaScript
 VBA解析JSON数据（4）–JavaScript进阶
 VBA解析JSON数据（5）–JavaScript回写Excel

由于工作关系，需要生成Json文件的配置，但vba使用dll实在太麻烦了，换了台电脑又需要重新引用，所以决定写Json的解析。
 
第一步：将字符串格式化。
 
思路：逐个字符判断该字符所属的类型，期望能将不同格式的Json字符串修改为统一格式的字符串。
 
将Json字符串中，空格、回车、TAB、换行符这几种没任何意义的字符删除。
 
 
    Function StringToJson(st)
        Dim i As Integer, ThisChar As String, NextChar As String, LastChar As String
        Dim isInString As Boolean, OutPutStr As String
        isInString = False
        OutPutStr = ""
        For i = 1 To Len(st)
            ThisChar = Mid(st, i, 1)
            NextChar = Mid(st, i + 1, 1)
            Select Case ThisChar
                Case """"
                    isInString = Not isInString
                    OutPutStr = OutPutStr & ThisChar
                Case " "
                    LastChar = Mid(st, i - 1, 1)
                    If isInString = True Then
                        OutPutStr = OutPutStr & ThisChar
                    End If
                Case Chr(13)
                Case Chr(9)
                Case Chr(10)
                Case Else
                    OutPutStr = OutPutStr & ThisChar
            End Select
        Next
        StringToJson = OutPutStr
    End Function

 
将格式化后的Json字符串，转换为便于阅读的格式（第一步的逆转换）
 

Function JsonFormate(st)
    Dim Index As Integer, OutPutStr As String
    Dim i, ThisChar, NextChar
    Dim isInString As Boolean
    Dim IndexMark
    isInString = False
    Index = 0
    OutPutStr = ""
    IndexMark = Chr(9)
    For i = 1 To Len(st)
        ThisChar = Mid(st, i, 1)
        NextChar = Mid(st, i + 1, 1)
        Select Case ThisChar
            Case """"
                isInString = Not isInString
                OutPutStr = OutPutStr & ThisChar
            Case "{"
                If NextChar <> "}" Then
                    Index = Index + 1
                End If
                OutPutStr = OutPutStr & ThisChar & Chr(13) & IndexBlank(Index, IndexMark)

            Case "}"

                If NextChar = "," Then
                    OutPutStr = OutPutStr & ThisChar

                ElseIf NextChar = "]" Or NextChar = "}" Then
                    Index = Index - 1
                    OutPutStr = OutPutStr & ThisChar & Chr(13) & IndexBlank(Index, IndexMark)
                Else
                    OutPutStr = OutPutStr & ThisChar
                End If
            Case "["
                If NextChar <> "]" Then
                    Index = Index + 1
                End If
                OutPutStr = OutPutStr & ThisChar & Chr(13) & IndexBlank(Index, IndexMark)

            Case "]"
                If NextChar = "," Then
                    OutPutStr = OutPutStr & ThisChar
                ElseIf NextChar = "]" Or NextChar = "}" Then
                    Index = Index - 1
                    OutPutStr = OutPutStr & ThisChar & Chr(13) & IndexBlank(Index, IndexMark)
                Else
                    OutPutStr = OutPutStr & ThisChar
                End If
            Case ":"
                If isInString = False Then
                    OutPutStr = OutPutStr & ThisChar & " "
                Else
                    OutPutStr = OutPutStr & ThisChar
                End If
            Case ","
                If isInString = False Then
                    OutPutStr = OutPutStr & ThisChar & Chr(13) & IndexBlank(Index, IndexMark)
                Else
                    OutPutStr = OutPutStr & ThisChar
                End If
            Case Else
                If NextChar = "]" Or NextChar = "}" Then
                    Index = Index - 1
                    OutPutStr = OutPutStr & ThisChar & Chr(13) & IndexBlank(Index, IndexMark)
                Else
                    OutPutStr = OutPutStr & ThisChar
                End If
        End Select
    Next
    JsonFormate = OutPutStr
End Function
Function IndexBlank(Index, IndexMark)
    Dim s, i
    s = ""
    If Index > 0 Then
        For i = 1 To Index
            s = s & IndexMark
        Next
    End If
    IndexBlank = s
End Function

 

 

Sub excelToJsonFileExample()
Dim excelRange As Range
Dim jsonItems As New Collection
Dim jsonDictionary As New Dictionary
Dim jsonFileObject As New FileSystemObject
Dim jsonFileExport As TextStream
Dim i As Long
Dim cell As Variant

Set excelRange = Cells(1, 1).CurrentRegion

For i = 2 To excelRange.Rows.Count
    jsonDictionary("id") = Cells(i, 1)
    jsonDictionary("name") = Cells(i, 2)
    jsonDictionary("username") = Cells(i, 3)
    jsonDictionary("email") = Cells(i, 4)
    jsonDictionary("street") = Cells(i, 5)
    jsonDictionary("suite") = Cells(i, 6)
    jsonDictionary("city") = Cells(i, 7)
    jsonDictionary("zipcode") = Cells(i, 8)
    jsonDictionary("phone") = Cells(i, 9)
    jsonDictionary("website") = Cells(i, 10)
    jsonDictionary("company") = Cells(i, 11)

    jsonItems.Add jsonDictionary
    Set jsonDictionary = Nothing
Next i

‘change the path below to save where you desire
Set jsonFileExport = jsonFileObject.CreateTextFile("C:\Users\username\Desktop\jsonExample.json", True)
jsonFileExport.WriteLine (JsonConverter.ConvertToJson(jsonItems, Whitespace:=3))

End Sub
 
参考
 http://excelerator.solutions/2017/08/24/convert-excel-to-json-using-vba/