用vba excel转json

Question

我有这个代码。它将excel文件转换为json格式。 a, b, c... 是我的标题：

Public Sub json_file()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim fs As Object
Dim jsonfile
Dim rangetoexport As Range
Dim rangetoexport2 As Range
Dim rangetoexport3 As Range
Dim rowcounter As Long
Dim columncounter As Long
Dim linedata As String
Dim rng As Range

Range("A1").Select
Selection.End(xlDown).Select
Dim lRow As Long
lRow = ActiveCell.Row

Set rangetoexport = Sheets(1).Range("A1:N" & lRow)
Set rangetoexport2 = Sheets(1).Range("H1:K" & lRow)
Set rangetoexport3 = Sheets(1).Range("L1:N" & lRow)

Set fs = CreateObject("Scripting.FileSystemObject")

Set jsonfile = fs.CreateTextFile("C:\Users\Desktop\Files\" & "jsondata.txt", True)

linedata = "["
jsonfile.WriteLine linedata

For rowcounter = 2 To rangetoexport.Rows.Count
linedata = ""
    For columncounter = 1 To 7
        linedata = linedata & """" & rangetoexport.Cells(1, columncounter) & """" & ":" & """" & rangetoexport.Cells(rowcounter, columncounter) & """" & ","
    Next
    linedata = Left(linedata, Len(linedata) - 1)
    
    For columncounter = 1 To 4
        linedata = linedata & """" & rangetoexport2.Cells(1, columncounter) & """" & ":" & "" & rangetoexport2.Cells(rowcounter, columncounter) & "" & ","
    Next
    linedata = Left(linedata, Len(linedata) - 1)
        
    For columncounter = 1 To 3
        linedata = linedata & """" & rangetoexport3.Cells(1, columncounter) & """" & ":" & """" & rangetoexport3.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

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

这是一行输出的样子：

{“a”：“1234”，“b”：“0”，“c”：“真”，“d”：“真”，“e”：“1”，“f” : "24", "g": "null" (这里没有逗号)"j": 151.70, "k": 1, "l": 2, "m": true, "n": “空”、“y”：“真”、“z”：“-1”}

我需要它看起来像这样：

{
"a": "1234",
"b": 0,
"c": true,
"d": true,
"e": 1,
"f": 24,
"g": null,
"thresholdValues":
   {
    "j": 151.70,
    "k": 1,
    "l": 2,
    "m": true
   },
"n": null,
"y": true,
"z": -1
}

所以我需要在标题 j 的开头添加 , "thresholdValues": {，在标题 m 的末尾添加 },。有没有办法做到这一点？

Answer 1

试试

Option Explicit

Public Sub create_json_file2()
   
    Const FILENAME = "jsondata.txt"
    Const FOLDER = "C:\Users\Desktop\"
    Const q = """"

    Dim ar1, fso, ts
    Dim r As Long, c As Long, c2 As Long, lrow As Long
    Dim s As String

    lrow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    ar1 = Sheets(1).Range("A1:N" & lrow).Value2
 
    ' build json string
    s = "[{" & vbCrLf

    For r = 2 To UBound(ar1)
        If r > 2 Then s = s & ",{" & vbCrLf

        For c = 1 To UBound(ar1, 2)
            If c > 1 Then s = s & "," & vbCrLf
            If c = 8 Then
                s = s & q & "thresholdValues" & q & ":{"
                For c2 = 0 To 3
                    If c2 > 0 Then s = s & ","
                     s = s & q & ar1(1, c2 + c) & q & ":" 
                     If c2 = 0 then
                         s = s & ar1(r, c2 + c)
                     Else
                         s = s & q & ar1(r, c2 + c) & q
                     End If
                Next
                s = s & "}"
                c = c + 3
            Else
                s = s & q & ar1(1, c) & q & ":" & q & ar1(r, c) & q
            End If
        Next
        s = s & "}" & vbCrLf
    Next
    s = s & "]"

    ' write out
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.CreateTextFile(FOLDER & FILENAME, True)
    ts.Write s
    MsgBox lrow - 1 & " rows exported to " & FOLDER & FILENAME, vbInformation
End Sub