Saving Excel sheet as JSON file

Solution 1:

I've combined jcbermu’s answer and JanHudecek’s answer with a UTF-8 version (snippets found here) which keeps accents and other Unicode goodness.

It saves the file beside the active workbook file but with the .json file extension. It's fast. It can be easily formatted in VS Code (Shift+Alt+F).

To use it, hit Alt+F11 to get to the VBA code editor, open the code for your active worksheet, then paste it into the code window. Hit F5 to run.

Public Sub tojson()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    jsonFilename = fso.GetBaseName(ActiveWorkbook.Name) & ".json"
    fullFilePath = Application.ActiveWorkbook.Path & "\" & jsonFilename

    Dim fileStream As Object
    Set fileStream = CreateObject("ADODB.Stream")
    fileStream.Type = 2 'Specify stream type - we want To save text/string data.
    fileStream.Charset = "utf-8" 'Specify charset For the source text data.
    fileStream.Open 'Open the stream And write binary data To the object

    Dim wkb As Workbook
    Set wkb = ThisWorkbook

    Dim wks As Worksheet
    Set wks = wkb.Sheets(1)

    lcolumn = wks.Cells(1, Columns.Count).End(xlToLeft).Column
    lrow = wks.Cells(Rows.Count, "A").End(xlUp).Row
    Dim titles() As String
    ReDim titles(lcolumn)
    For i = 1 To lcolumn
        titles(i) = wks.Cells(1, i)
    Next i
    fileStream.WriteText "["
    dq = """"
    escapedDq = "\"""
    For j = 2 To lrow
        For i = 1 To lcolumn
            If i = 1 Then
                fileStream.WriteText "{"
            End If
            cellvalue = Replace(wks.Cells(j, i), dq, escapedDq)
            fileStream.WriteText dq & titles(i) & dq & ":" & dq & cellvalue & dq
            If i <> lcolumn Then
                fileStream.WriteText ","
            End If
        Next i
        fileStream.WriteText "}"
        If j <> lrow Then
            fileStream.WriteText ","
        End If
    Next j
    fileStream.WriteText "]"
    fileStream.SaveToFile fullFilePath, 2 'Save binary data To disk
    a = MsgBox("Saved to " & fullFilePath, vbOKOnly)
End Sub

Solution 2:

If you want the script to actually finish before you're a pensioner, I suggest writing to the output file immediately instead of concatenating the string var:

Public Sub tojson()
    savename = "exportedxls.json"
    myFile = Application.DefaultFilePath & "\" & savename
    Open myFile For Output As #1
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(1)
    lcolumn = wks.Cells(1, Columns.Count).End(xlToLeft).Column
    lrow = wks.Cells(Rows.Count, "A").End(xlUp).Row
    Dim titles() As String
    ReDim titles(lcolumn)
    For i = 1 To lcolumn
        titles(i) = wks.Cells(1, i)
    Next i
    Print #1, "["
    dq = """"
    For j = 2 To lrow
        For i = 1 To lcolumn
            If i = 1 Then
                Print #1, "{"
            End If
            cellvalue = wks.Cells(j, i)
            Print #1, dq & titles(i) & dq & ":" & dq & cellvalue & dq
            If i <> lcolumn Then
                Print #1, ","
            End If
        Next i
        Print #1, "}"
        If j <> lrow Then
            Print #1, ","
        End If
    Next j
    Print #1, "]"
    Close #1
    a = MsgBox("Saved as " & savename, vbOKOnly)
End Sub

Solution 3:

This VBA code will work :

Public Sub tojson()
    savename = "exportedxls.json"
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(1)
    lcolumn = wks.Cells(1, Columns.Count).End(xlToLeft).Column
    lrow = wks.Cells(Rows.Count, "A").End(xlUp).Row
    Dim titles() As String
    ReDim titles(lcolumn)
    For i = 1 To lcolumn
        titles(i) = wks.Cells(1, i)
    Next i
    json = "["
    dq = """"
    For j = 2 To lrow
        For i = 1 To lcolumn
            If i = 1 Then
                json = json & "{"
            End If
            cellvalue = wks.Cells(j, i)
            json = json & dq & titles(i) & dq & ":" & dq & cellvalue & dq
            If i <> lcolumn Then
                json = json & ","
            End If
        Next i
        json = json & "}"
        If j <> lrow Then
            json = json & ","
        End If
    Next j
    json = json & "]"
    myFile = Application.DefaultFilePath & "\" & savename
    Open myFile For Output As #1
    Print #1, json
    Close #1
    a = MsgBox("Saved as " & savename, vbOKOnly)
End Sub

Open VBA /Macros with ALT+F11.

On the left side double click on The worksheet, on the right side paste the code.

Set the variable savename to the name that you want for the json file and that's all.