Snasui Excel Forum

Code: Select all

Function toJSON(rangeToParse As Range, parseAsArrays As Boolean) As String
    Dim rowCounter As Integer
    Dim columnCounter As Integer
    Dim parsedData As String: parsedData = "["
    Dim temp As String

    If parseAsArrays Then ' Check to see if we need to make our JSON an array; if not, we'll make it an object.
    
    For rowCounter = 2 To rangeToParse.Rows.Count ' Loop through each row starting with the second row so we don't include the header
            temp = "" ' Reset temp's value
            
            For columnCounter = 1 To rangeToParse.Columns.Count ' Loop through each column
                temp = temp & """" & rangeToParse.Cells(1, columnCounter) & """" & ","
            Next

            temp = "{" & Left(temp, Len(temp) - 1) & "}," ' Remove extra comma from after last object
            parsedData = parsedData & temp ' Add temp to the data we've already parsed
        Next
        
    Else
                For rowCounter = 1 To rangeToParse.Rows.Count ' Loop through each row
            temp = "" ' Reset temp's value

            For columnCounter = 1 To rangeToParse.Columns.Count ' Loop through each column
                temp = temp & """" & rangeToParse.Cells(rowCounter, columnCounter) & """" & ":" & """" & rangeToParse.Cells(rowCounter, columnCounter) & """" & ","
            Next

            temp = "[" & Left(temp, Len(temp) - 1) & "]," ' Remove extra comma from after last object
            parsedData = parsedData & temp ' Add temp to the data we've already parsed
        Next
    End If


    parsedData = Left(parsedData, Len(parsedData) - 1) & "]" ' Remove extra comma and add the closing bracket for the JSON array
    toJSON = parsedData ' Return the JSON data
End Function

Code: Select all

Dim rs As Range, r As Range
Dim qt$, v$, a$
Dim strArr(), i%, j%
Dim strJson$, strF$, c1$
With Worksheets("Sheet1")
    Set rs = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
    qt = Chr(34)
    a = .Range("a1").Value
    strF = qt & a & qt & ","
    For i = 1 To 2
        j = 0
        For Each r In rs
            ReDim Preserve strArr(j)
            c1 = qt & r.Value & qt & Chr(58)
            v = r.Offset(0, i).Value
            If Len(v) = 0 Then
                strArr(j) = c1 & qt & qt
            ElseIf IsNumeric(v) Then
                strArr(j) = c1 & v
            Else
                strArr(j) = c1 & qt & v & qt
            End If
            j = j + 1
        Next r
        strJson = strJson & IIf(i > 1, vbLf & strF & "{", ",{") & _
            vbLf & VBA.Join(strArr, "," & vbLf) & "}"
    Next i
    .Range("f15").Value = "[" & qt & a & qt & strJson & "]"
End With

Code: Select all

Sub cJs()
    Dim r As Range, q$, n$, a, b(1), i&, j&
    q = """": n = vbLf
    a = [A1].CurrentRegion
    For i = 1 To UBound(a)
        For j = 1 To 3
            If Not Application.IsNumber(a(i, j)) Then a(i, j) = q & a(i, j) & q
            If i > 1 And j > 1 Then b(j - 2) = b(j - 2) & "," & n & a(i, 1) & ":" & a(i, j)
    Next j, i
    [f15] = "[" & a(1, 1) & ",{" & Mid(b(0), 2) & "}," & n & a(1, 1) & ",{" & Mid(b(1), 2) & "}]"
End Sub

Code: Select all

Dim a, b, c, q$, h$, i%, j%, f$, v$
q = Chr(34): f = vbLf: a = [a1].CurrentRegion
ReDim b(1 To UBound(a, 1) - 1), c(1 To UBound(a, 2) - 1)
For i = 1 To UBound(c)
    For j = 2 To UBound(a)
        v = a(j, i + 1)
        b(j - 1) = q & a(j, 1) & q & ":" & IIf(VarType(v) <> 5, q & v & q, v)
    Next j
    c(i) = Join(b, "," & f)
Next i
h = q & [a1] & q & ",{" & f: [f15] = "[" & h & Join(c, "}" & f & h) & "}]"

Code: Select all

Sub cJs()
Dim a, b, c, q$, h$, i%, j%, f$, v$
q = Chr(34): f = vbLf: a = [a1].CurrentRegion
ReDim b(1 To UBound(a, 1) - 1), c(1 To UBound(a, 2) - 1)
For i = 1 To UBound(c)
    For j = 2 To UBound(a)
        v = a(j, i + 1)
        b(j - 1) = q & a(j, 1) & q & ":" & IIf(VarType(v) <> 5, q & v & q, v)
    Next j
    c(i) = Join(b, "," & f)
Next i
h = q & [a1] & q & ",{" & f: [f15] = "[" & h & Join(c, "}" & f & h) & "}]"


End Sub

Code: Select all

Dim ra As Range, rs As Range, r As Range
Dim h$, q$, l$, f$, i%, j%, k%, a(), b(), c()
q = Chr(34): f = vbLf
Set ra = [c:c].SpecialCells(xlCellTypeConstants)
For i = 1 To ra.Areas.Count
    Set rs = ra.Areas(i)
    h = q & Cells(rs(1).Row - 1, 1) & q & ",{"
    k = 0
    For Each r In rs
        If Val(r) Then
            ReDim Preserve a(k), b(k)
            l = q & r.Offset(0, -2) & q & ":"
            a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & r
            k = k + 1
        End If
    Next r
    If k > 0 Then
        ReDim Preserve c(j)
        c(j) = h & f & Join(a, "," & f) & "}," & f & f & _
            h & f & Join(b, "," & f) & "}"
        j = j + 1
    End If
Next i
[f15] = "[" & Join(c, "," & f & f) & "]"

Code: Select all

Sub cJs()
Dim r As Range, q$, n$, a, b, i&, j&, js$, h$, c$
q = """": n = vbLf: c = "}," & n
For Each r In Columns(2).SpecialCells(2).Areas
    ReDim b(1)
    a = r.Offset(, -1).Resize(, 3).Value2
    h = q & r(0, 0) & q & ",{"
    For i = 1 To UBound(a)
        For j = 1 To 3
            If Not Application.IsNumber(a(i, j)) Then a(i, j) = q & a(i, j) & q
            If j > 1 And a(i, 3) > 0 Then b(j - 2) = b(j - 2) & "," & n & a(i, 1) & ":" & a(i, j)
    Next j, i
    If b(0) <> "" Then js = js & n & h & Mid(b(0), 2) & c & n & h & Mid(b(1), 2) & c
Next
    [f15] = "[" & Mid(js, 2) & "]"
End Sub

Code: Select all

a(k) = l & q & r.Offset(0, -1) & q: b(k) = l & """" & r & """"

Code: Select all

Private Sub CommandButton1_Click()

'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")


'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = Sheets("Sheet1").Range("G2").Value & "_" & Sheets("Sheet1").Range("G3").Value & ".json"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="JSON Files (*.json), *.json", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypeJSONFile, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "JSON file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create JSON file"
    Resume exitHandler

End Sub

Code: Select all

Private Sub CommandButton1_Click()

'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant

On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = Sheets("Sheet1").Range("G2").Value & "_" & Sheets("Sheet1").Range("G3").Value & ".json"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
'    (InitialFileName:=strPathFile, _
'        FileFilter:="JSON Files (*.json), *.json", _
'        Title:="Select Folder and FileName to save")

Dim jsonEpt As Object
Dim jsonFobj As Object

Set jsonFobj = CreateObject("Scripting.FileSystemObject")
Set jsonEpt = jsonFobj.CreateTextFile(strFile, True)
jsonEpt.WriteLine ([f15])

'export to PDF if a folder was selected
'If myFile <> "False" Then
'    wsA.ExportAsFixedFormat _
'        Type:=xlTypeJSONFile, _
'        Filename:=myFile, _
'        Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, _
'        IgnorePrintAreas:=False, _
'        OpenAfterPublish:=False
'    'confirmation message with file info
'    MsgBox "JSON file has been created: " _
'      & vbCrLf _
'      & myFile
'End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create JSON file"
    Resume exitHandler

End Sub

Code: Select all

--other Code-----
' select folder for file
myFile = Application.GetSaveAsFilename _
        (InitialFileName:=strPathFile, _
        FileFilter:="JSON Files (*.json), *.json", _
        Title:="Select Folder and FileName to save")

Dim jsonEpt As Object
Dim jsonFobj As Object

Set jsonFobj = CreateObject("Scripting.FileSystemObject")
Set jsonEpt = jsonFobj.CreateTextFile(myFile, True)
jsonEpt.WriteLine ([f15])

--other Code-----