Nested json object with vba-CodePudding

I found this code on the internet that creates a json file from an excel file. http://www.excelvbamacros.in/2015/01/export-range-in-jason-format.html

This is the code:

Public Sub create_json_file()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

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

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

Set rangetoexport = Sheets(1).Range("A1:N" & lRow)
Set fs = CreateObject("Scripting.FileSystemObject")

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

linedata = "["
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

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub

It works perfect but my json has to have a nested json object. It needs to look like this:

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

Code does this:

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

a,b,h... these are columns and my example is just one row. I couldn't add to the code so that it would create the "h": part. Can anyone help me?

CodePudding user response：

Add another loop for sheet2 inside the one for sheet1 .

Option Explicit

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

    Dim ar1, ar2, 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:K" & lrow).Value2
    ar2 = Sheets(2).Range("A1:D" & 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
            s = s & q & ar1(1, c) & q & ":"

            If ar1(1, c) = "h" Then
                s = s & "{" & vbCrLf
                For c2 = 1 To UBound(ar2, 2)
                    If c2 > 1 Then s = s & ","
                    s = s & q & ar2(1, c2) & q & ":" _
                          & q & ar2(r, c2) & q
                Next
                s = s & "}"
            Else
                s = s & 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