Nested json object with vba - json

Question

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?

Answer 1

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