excel 到 json 和 vba

Question

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

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
}

所以我需要在header j的开头添加, "thresholdValues": {, and },在 header 米结束时。有办法吗？

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

excel 到 json 和 vba

excel to json with vba

json

excel

vba

for-loop

converters