Pages

Saturday, January 31, 2015

Export Range in Json Format

Macro to Export Range in Json Format


Option Explicit

Sub export_in_json_format()

    Dim fs As Object
    Dim jsonfile
    Dim rangetoexport As Range
    Dim rowcounter As Long
    Dim columncounter As Long
    Dim linedata As String
   
    ' change range here
    Set rangetoexport = Sheet1.Range("a1:d8")
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    ' change dir here
   
    Set jsonfile = fs.CreateTextFile("C:\Users\xx\Desktop\" & "jsondata.json", True)
   
    linedata = "{""Output"": ["
    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
   
   
End Sub

5 comments:

  1. This works really well! Thanks!

    ReplyDelete
  2. Thanks, this a real good code

    im add some change to ensure that the result remained in the folder with the sheet, and with a different name (using the current time and date for the name):

    ' change range here
    Set rangetoexport = Worksheets("Blad1").Range("$A:$J")

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set jsonfile = fs.CreateTextFile(ActiveWorkbook.Path & "\" & Format(Date, "dd-mm-yy") & Format(Time(), "-hh-mm-ss") & ".json", True)

    ReplyDelete
  3. This tutorial is really useful for me, thanks a lot.

    ReplyDelete
  4. Thanks! This is very cool and saved me a lot of time. My spreadsheet had some "special" characters like �� and \.

    The first change to support the picture was to add a second True to create the file as Unicode.

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

    The second change was to add a replace function to escape \ to \\.

    linedata = Replace(linedata, "\", "\\")

    Here's the complete updated version if anybody is interested.

    Option Explicit

    Sub Update()

    Dim waitTime As Integer
    Dim timesRun As Integer
    waitTime = 20
    timesRun = 0
    AreaPathMain.Main timesRun, waitTime
    End Sub

    Sub tableToJson()

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

    ' change range here
    Set rangetoexport = Sheet1.Range("B2:F116")

    Set fs = CreateObject("Scripting.FileSystemObject")
    ' change dir here

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

    linedata = "{""Output"": ["
    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
    linedata = Replace(linedata, "\", "\\")
    jsonfile.WriteLine linedata
    Next
    linedata = "]}"
    jsonfile.WriteLine linedata
    jsonfile.Close

    Set fs = Nothing

    End Sub

    ReplyDelete