Converting Excel sheet into Json

SanjanaSanju
June 7, 2024
216 views
0 votes
2 Answers

I am very new to Excel macro and need help with the below.

I have a nested json string as below.

  {
  "Version": 1,
  "Date": "2023-09-22",
  "Adjustment": 19,
  "stock": {
    "Rate": 1.41,
    "Price": 19
  },
  "units": [
    {
      "Place": "NW",
      "unitId": 2,
      "depart": [1, 2],
      "Usage": [
        {
          "fuel": "gas",
          "Rate": 19
        },
        {
          "fuel": "diesel",
          "Rate": 19
        }
      ],
      "ip": [
        {
          "fuel": "gas",
          "aCoef": 19
        },
        {
          "fuel": "diesel",
          "aCoef": 2
        }
      ]
    },
    {
      "Place": "London",
      "unitId": 2,
      "depart": [1, 2],
      "Usage": [
        {
          "fuel": "liquid",
          "Rate": 19
        }
      ],
      "Price": {
        "Rate1": 19,
        "Rate2": 19
      }
    }
  ]
}

I have flattened it as below in the excel.

whenever I update any row in the value column in excel I need a new json in column E with the updated value .
For Instance when I update adjustment value as 45 in the excel sheet,when I run a marco I want VBA code to generate a new json with the updated value as 45 for adjustment.Please provide inputs.
Thank you.

Code used

Sub UpdateJSON()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim key As String
    Dim value As String
    Dim jsonStr As String
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") 
    
    ' Find the last row with data
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Initialize JSON string
    jsonStr = "{"
    
    ' Iterate over each row to build the JSON structure
    For Each cell In ws.Range("A2:A" & lastRow)
        key = Trim(cell.Value)
        value = Trim(cell.Offset(0, 1).Value)
        jsonStr = jsonStr & BuildJSONString(key, value) & ","
    Next cell
    
    ' Remove trailing comma and close JSON string
    If Right(jsonStr, 1) = "," Then
        jsonStr = Left(jsonStr, Len(jsonStr) - 1)
    End If
    jsonStr = jsonStr & "}"
    
    ' Output the JSON string to the specified cell
    ws.Cells(1, 8).Value = jsonStr ' H1 corresponds to column 8
End Sub

Function BuildJSONString(key As String, value As String) As String
    Dim jsonSegment As String
    Dim keys As Variant
    Dim i As Integer
    Dim tempKey As String
    
    keys = Split(key, ".")
    
    ' Construct the JSON key path
    jsonSegment = ""
    For i = LBound(keys) To UBound(keys)
        tempKey = keys(i)
        ' Check if the key contains an array index
        If InStr(tempKey, "[") > 0 And InStr(tempKey, "]") > 0 Then
            tempKey = Replace(tempKey, "[", ":[")
        End If
        jsonSegment = jsonSegment & """" & tempKey & """:"
    Next i
    
    ' Add the value to the JSON key path
    If IsNumeric(value) Then
        jsonSegment = jsonSegment & value
    ElseIf Left(value, 1) = "[" And Right(value, 1) = "]" Then
        jsonSegment = jsonSegment & value
    Else
        jsonSegment = jsonSegment & """" & value & """"
    End If
    
    BuildJSONString = jsonSegment
End Function

Result obtained

{"inputVersion":3,"CVersion":0,"Adjustment":1222,"stock":"Rate":1.41,"stock":"Price":222,"units:[0]":"Place":"NW","units:[0]":"unitId":2,"units:[0]":"depart":[1, 2],"units:[0]":"usage:[0]":"fuel":"gas","units:[0]":"usage:[0]":"Rate":24,"units:[0]":"usage:[1]":"fuel":"Disel","units:[0]":"usage:[1]":"Rate":222,"units:[0]":"ip:[0]":"fuel":"gas","units:[0]":"ip:[0]":"aCoef":222,"units:[0]":"ip:[1]":"fuel":"disel","units:[0]":"ip:[1]":"aCoef":222,"units:[1]":"Name":"London","units:[1]":"unitId":2,"units:[1]":"depart":[1, 2],"units:[1]":"usage:[0]":"fuel":"liquid","units:[1]":"usage:[0]":"rate":99222,"units:[1]":"Price":"rate1":1222,"units:[1]":"Price":"rate2":16222}

But the expected json format is different in the above result.

Answers

Parsing JSON is more difficult and complex than you might have expected. Parsing nested JSON is even more complicated.
VBA-JSON is an excellent free tool for parsing JSON.
The code has been tested with your sample data, but there may be opportunities for further improvement.

Note:

Please include a reference to Microsoft Scripting Runtime before run the code.

Option Explicit

Sub excelToJson5()
    Dim jsonItems As New Collection
    Dim jsonDict As New Dictionary
    Dim FSO As New FileSystemObject
    Dim tsFile As TextStream
    Dim i As Long, iLoc As Long, sText As String
    Dim oColl2(), m As Long, oDict2(), mm As Long
    Dim oColl3(), k As Long, oDict3(), kk As Long
    Dim aKey1, aKey2, aKey3
    Dim sKey1 As String, sKey2 As String, sKey3 As String
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If InStr(Cells(i, 1), ".") > 0 Then
            aKey1 = Split(Cells(i, 1), ".")
            sKey1 = aKey1(0)
            iLoc = InStr(sKey1, "[")
            If iLoc > 0 Then
                sKey1 = Left(sKey1, iLoc - 1)
                m = m + 1
                ReDim Preserve oColl2(1 To m)
                Set oColl2(m) = New Collection
                Do
                    aKey1 = Split(Cells(i, 1), ".")
                    mm = mm + 1
                    ReDim Preserve oDict2(1 To mm)
                    Set oDict2(mm) = New Dictionary
                    Do
                        aKey2 = Split(Cells(i, 1), ".")
                        iLoc = InStr(aKey2(1), "[")
                        If iLoc > 0 Then
                            sKey2 = Left(aKey2(1), iLoc - 1)
                            k = k + 1
                            ReDim Preserve oColl3(1 To k)
                            Set oColl3(k) = New Collection
                            Do
                                kk = kk + 1
                                ReDim Preserve oDict3(1 To kk)
                                Set oDict3(kk) = New Dictionary
                                Do
                                    aKey3 = Split(Cells(i, 1), ".")
                                    sText = Cells(i, 2).Value
                                    oDict3(kk)(aKey3(2)) = sText
                                    i = i + 1
                                Loop Until i > 23 Or InStr(Cells(i, 1), aKey3(0) & "." & aKey3(1)) = 0
                                oColl3(k).Add oDict3(kk)
                            Loop Until i > 23 Or InStr(Cells(i, 1), aKey3(0) & "." & sKey2) = 0
                            Set oDict2(mm)(sKey2) = oColl3(k)
                            i = i - 1
                        Else
                            If UBound(aKey2) = 1 Then
                                sText = Cells(i, 2).Value
                                oDict2(mm)(aKey2(1)) = sText
                            ElseIf UBound(aKey2) = 2 Then
                                If Not oDict2(mm).Exists(aKey2(1)) Then
                                    Set oDict2(mm)(aKey2(1)) = New Dictionary
                                End If
                                sText = Cells(i, 2).Value
                                oDict2(mm)(aKey2(1))(aKey2(2)) = sText
                            End If
                        End If
                        i = i + 1
                    Loop Until i > 23 Or InStr(Cells(i, 1), aKey1(0)) = 0
                    oColl2(m).Add oDict2(mm)
                Loop Until i > 23 Or InStr(Cells(i, 1), sKey1) = 0
                Set jsonDict(sKey1) = oColl2(m)
            Else
                If Not jsonDict.Exists(sKey1) Then
                    Set jsonDict(sKey1) = New Dictionary
                End If
                sText = Cells(i, 2).Value
                jsonDict(sKey1)(aKey1(1)) = sText
            End If
        Else
            sText = Cells(i, 2).Value
            jsonDict(Cells(i, 1)) = sText
        End If
    Next i
    jsonItems.Add jsonDict
    Set jsonDict = Nothing
    Set tsFile = FSO.CreateTextFile("D:TEMPjsonExample.json", True)
    sText = JsonConverter.ConvertToJson(jsonItems, Whitespace:=3)
    sText = Replace(sText, Chr(34) & "[", "[")
    sText = Replace(sText, "]" & Chr(34), "]")
    tsFile.WriteLine (sText)
    Debug.Print "DONE"
End Sub

Output:

[
   {
      "inputVersion": "3",
      "CVersion": "0",
      "Adjustment": "1222",
      "stock": {
         "Rate": "1.41",
         "Price": "222"
      },
      "units": [
         {
            "Place": "NW",
            "unitId": "2",
            "depart": [1, 2],
            "usage": [
               {
                  "fuel": "gas",
                  "Rate": "24"
               },
               {
                  "fuel": "Disel",
                  "Rate": "222"
               }
            ],
            "ip": [
               {
                  "fuel": "gas",
                  "aCoef": "222"
               },
               {
                  "fuel": "disel",
                  "aCoef": "222"
               }
            ]
         },
         {
            "Name": "London",
            "unitId": "2",
            "depart": [1, 2],
            "usage": [
               {
                  "fuel": "liquid",
                  "rate": "99222"
               }
            ],
            "Price": {
               "rate1": "1222",
               "rate2": "16222"
            }
         }
      ]
   }
]

Slightly different approach also using VBA-JSON:

Sub DoIt()
    
    Dim root As Object, rw As Range, pth, v, arr, el, res, d
    Dim obj As Object, n, i As Long, ub As Long, prevType As String
    
    Set root = dict() 'root json object
    
    For Each rw In [A1:B25].Rows        'loop over data rows
        pth = Trim(rw.Cells(1).Value)
        arr = Split(pth, ".")        'split into individual components (note: no support for (eg) "blah[0][1]")
        ub = UBound(arr)
        v = Trim(rw.Cells(2).Value)  'value to be assigned
        
       
        Set obj = root  'starting at the root dict
        prevType = "d"
        For i = 0 To ub
            n = 0
            el = Trim(arr(i))
            'see if this part of the path is a collection/array
            If el Like "*[[]#]" Then
                n = Split(el, "[")(1)
                n = 1 + CLng(Replace(n, "]", "")) 'one-based element index
                el = Split(el, "[")(0)
            End If
            'Debug.Print el, n
            
            If i < ub Then
                'building the path...
                If n > 0 Then
                    If Not obj.Exists(el) Then
                        obj.Add el, New Collection
                    End If
                    Set obj = GetArrayDict(obj(el), n)
                Else
                    If Not obj.Exists(el) Then obj.Add el, dict()
                    Set obj = obj(el)
                End If
            Else
                'adding a value
                ParseValue v, res
                If n = 0 Then   'not adding to a collection
                    obj.Add el, res
                Else
                    If Not obj.Exists(el) Then
                        obj.Add el, New Collection
                    End If
                    AddToCollection obj(el), CLng(n), res
                End If
            End If
         Next i
    Next rw
    
    Debug.Print JsonConverter.ConvertToJson(root, 3)

End Sub

'convenience function
Function dict()
    Set dict = CreateObject("scripting.dictionary")
    dict.CompareMode = 1 'case-insensitive
End Function

'Given a json value `v`, check its type and return a "parsed" version via `res`
'Only checking types array/number/text
Sub ParseValue(ByVal v, ByRef res As Variant)
    Dim arr, el, tmp
    If v Like "[[]*]" Then        'eg [1,2]
        Set res = New Collection  'new array/collection
        v = Trim(Replace(Replace(v, "[", ""), "]", ""))
        arr = Split(v, ",")
        For Each el In arr        'populate collection
            ParseValue Trim(el), tmp
            res.Add tmp
        Next el
    ElseIf IsNumeric(v) Then
        res = CDbl(v)
    Else
        res = CStr(v)
    End If
End Sub


'Get the dictionary at position `n` in collection `col`
'  Resize col if needed
Function GetArrayDict(col As Object, n) As Object
    Do While col.Count < n
        col.Add dict() 'empy object
    Loop
    Set GetArrayDict = col(n)
End Function

'Ensure collection `col` is sized to add `v` at position `n`
'   and add the value
Sub AddToCollection(col As Object, n As Long, v)
    Dim i As Long, indx As Long
    i = col.Count
    For indx = i + 1 To n
        col.Add Empty, CStr(indx) 'add with key
    Next indx
    col.Remove CStr(n) 'remove by key
    col.Add v, CStr(n) 'add v with key
End Sub

Output:

{
   "inputVersion": 3,
   "CVersion": 0,
   "Adjustment": 1222,
   "stock": {
      "Rate": 1.41,
      "Price": 227
   },
   "units": [
      {
         "Place": "NW",
         "unitld": 2,
         "depart": [
            1,
            "dog"
         ],
         "usage": [
            {
               "fuel": "gas",
               "Rate": 24
            },
            {
               "fuel": "Disel",
               "Rate": 222
            }
         ],
         "ip": [
            {
               "fuel": "gas",
               "aCoef": 222
            },
            {
               "fuel": "disel",
               "aCoef": 222
            }
         ]
      },
      {
         "Name": "London",
         "unitld": 2,
         "depart": [
            1,
            "fresh"
         ],
         "usage": [
            {
               "fuel": "liquid",
               "rate": 99222
            }
         ],
         "price": {
            "rate1": 1222,
            "rate2": 16222
         }
      }
   ]
}

Please signup or login to give your own answer.

Click here to cancel reply.