Consulting

Results 1 to 6 of 6

Thread: Excel to JSON -- bracketing

  1. #1

    Excel to JSON -- bracketing

    I'm trying to re-create JSON file by using Excel VBA and Tim Hall's Excel JSON classes.
    I extract the value of the source JSON to Excel, modify it, then recreate the JSON file.
    Unfortunately the bracketing of the recreated JSON file is not equal to source JSON
    I'm not sure how to solve this. Below I post the current VBA code, hope somebody can help.
    Thank you.

    Source JSON:
    {
        "mat": [{
            "system": "DOM RS Sigma",
            "materialmat": "3019SIG",
            "kmattext": "Riegelaufschraubschlo\u00df 3019SIG m. B\u00fcgel",
            "vorlage": "",
            "typ": "3019",
            "merkmale": [{
                "merkmal": "B_AUSFUEHRUNG_ROHR_PLATTE",
                "merkmaltext": "AUSFUEHRUNG ROHR PLATTE",
                "mewerte": [{
                    "mewert": "P",
                    "memerktext": "AUSF\u00dcHRUNG PLATTE"
                }]
            }]
        }]
    }
    Recreated JSON:
    {
      "mat": [
        [
          {
            "system": "DOM RS Sigma",
            "materialmat": "3019SIG",
            "kmattext": "Riegelaufschraubschlo\u00DF 3019SIG m. B\u00FCgel",
            "typ": "3019",
            "merkmale": [
              {
                "merkmal": "B_AUSFUEHRUNG_ROHR_PLATTE",
                "merkmaltext": "AUSFUEHRUNG ROHR PLATTE",
                "mewerte": [
                  {
                    "mewert": "P",
                    "memerktext": "AUSF\u00DCHRUNG PLATTE"
                  }
                ]
              }
            ]
          }
        ]
      ]
    }
    The VBA code:
    Sub ExcelToNestedJson()
        Dim wb As Workbook
        Dim wsF As Worksheet, wsT As Worksheet
        Dim MATcoll As New Collection
        Dim MTcoll As New Collection, MKcoll As New Collection, MWcoll As New Collection
        Dim MTdict As New Dictionary, MKdict As New Dictionary, MWdict As New Dictionary
        Dim MATdict As New Dictionary
        Dim SearchRange As Range, rgSearchMT As Range, rgSearchMK As Range, rgSearchMW As Range
        Dim FindWhat As Variant
        Dim FoundCells As Range, FoundCellsMT As Range, FoundCellsMK As Range, FoundCellsMW As Range
        Dim FoundCell As Range
        Dim MT As Long, MK As Long, MW As Long
        Dim vrMT As Variant, vrMK As Variant, vrMW As Variant
        Dim colMT As String, colMK As String, colMW As String
        Dim sep As String, dPath As String
        
        Set wb = ThisWorkbook
        Set wsT = wb.Sheets("Values")
            wsT.Columns.AutoFit
            colMT = "A": colMK = "I": colMW = "K"
            
        sep = Application.PathSeparator
        dPath = Environ("USERPROFILE") & sep & "Desktop"
        
        Dim LLF As String, LLT As String, stF() As String
        Dim LRF As Long, LRT As Long
        Dim LCF As Long, LCT As Long
        Dim R As Long, C As Long
        Dim RT As Long, CT As Long
        
        LRT = Last(1, wsT.Cells)
        Set rgSearchMT = wsT.Range(colMT & "2:" & colMT & LRT)
        Set FoundCellsMT = FindAll(SearchRange:=rgSearchMT, _
                                FindWhat:="*", _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByColumns, _
                                MatchCase:=False, _
                                BeginsWith:=vbNullString, _
                                EndsWith:=vbNullString, _
                                BeginEndCompare:=vbTextCompare)
                                
        If Not FoundCellsMT Is Nothing Then
            vrMT = Split(Replace(Replace(FoundCellsMT.Address, "$", ""), colMT, ""), ",")
            'Loop material mat
            For MT = LBound(vrMT) To UBound(vrMT)
                With wsT
                    R = CLng(vrMT(MT))
                    For C = 1 To 8
                        If .Cells(R, C).Value <> "" Then
                            MTdict(.Cells(1, C)) = .Cells(R, C).Text
                        End If
                    Next C
                End With
                
                'determine Merkmal range
                If MT <> UBound(vrMT) Then
                    Set rgSearchMK = wsT.Range(colMK & CInt(vrMT(MT)) & ":" & colMK & CInt(vrMT(MT + 1)) - 1)
                Else
                    Set rgSearchMK = wsT.Range(colMK & CInt(vrMT(MT)) & ":" & colMK & LRT)
                End If
                
                Set FoundCellsMK = FindAll(SearchRange:=rgSearchMK, _
                                        FindWhat:="*", _
                                        LookIn:=xlValues, _
                                        LookAt:=xlWhole, _
                                        SearchOrder:=xlByColumns, _
                                        MatchCase:=False, _
                                        BeginsWith:=vbNullString, _
                                        EndsWith:=vbNullString, _
                                        BeginEndCompare:=vbTextCompare)
                                        
                If Not FoundCellsMK Is Nothing Then
                    vrMK = Split(Replace(Replace(FoundCellsMK.Address, "$", ""), colMK, ""), ",")
                    'loop Merkmal
                    For MK = LBound(vrMK) To UBound(vrMK)
                        'Debug.Print , "MK", CInt(vrMK(MK))
                        With wsT
                            R = CLng(vrMK(MK))
                            For C = 9 To 10
                                If .Cells(R, C).Value <> "" Then
                                    MKdict(.Cells(1, C)) = .Cells(R, C).Text
                                End If
                            Next C
                        End With
                        
                        'determine Mewert range
                        If MK <> UBound(vrMK) And MT <> UBound(vrMT) Then
                            Set rgSearchMW = wsT.Range(colMW & CInt(vrMK(MK)) & ":" & colMW & CInt(vrMK(MK + 1)) - 1)
                        End If
                        If MK <> UBound(vrMK) And MT = UBound(vrMT) Then
                            Set rgSearchMW = wsT.Range(colMW & CInt(vrMK(MK)) & ":" & colMW & CInt(vrMK(MK + 1)) - 1)
                        End If
                        If MK = UBound(vrMK) And MT <> UBound(vrMT) Then
                            Set rgSearchMW = wsT.Range(colMW & CInt(vrMK(MK)) & ":" & colMW & CInt(vrMT(MT + 1)) - 1)
                        End If
                        If MK = UBound(vrMK) And MT = UBound(vrMT) Then
                            Set rgSearchMW = wsT.Range(colMW & CInt(vrMK(MK)) & ":" & colMW & LRT)
                        End If
                        
                        vrMW = Split(Replace(Replace(Replace(rgSearchMW.Address, "$", ""), colMW, ""), ":", ","), ",")
                        
                        'loop Mewert
                        For MW = vrMW(LBound(vrMW)) To vrMW(UBound(vrMW))
                            With wsT
                                R = MW
                                If .Range(colMW & R).Value <> "" Then
                                    For C = 11 To 13
                                        If .Cells(R, C).Value <> "" Then
                                            MWdict(.Cells(1, C)) = .Cells(R, C).Text
                                        End If
                                    Next C
                                End If
                            End With
                            
                            'add to collection and reset
                            MWcoll.Add MWdict
                            Set MWdict = Nothing
                        Next MW
                        MWcoll.Remove 1
                        MKdict.Add "mewerte", MWcoll
                        MKcoll.Add MKdict
                        Set MKdict = Nothing
                        Set MWcoll = Nothing
                    Next MK
                End If
                
                MTdict.Add "merkmale", MKcoll
                MTcoll.Add MTdict
                MATcoll.Add MTcoll
                Set MKcoll = Nothing
                Set MTdict = Nothing
                Set MTcoll = Nothing
            Next MT
        End If
        
        MATdict.Add "mat", MATcoll
        
        Dim myfile As String
        Dim fn As Integer
            fn = FreeFile
            
        myfile = dPath & sep & "Injected " & JSONFileName
        Open myfile For Output As fn
        Print #fn, ConvertToJson(MATdict, Whitespace:=2)
        Close #fn
        
    End Sub

  2. #2
    VBAX Regular arangogs's Avatar
    Joined
    Jun 2009
    Location
    Ayrshire, Scotland
    Posts
    17
    Location
    HiChooriang,

    You are adding an aditional '[' bracket(see segment from recreated JSON below), which is throwing out your structure. I assume this is taking place in the ConvertToJson function that you have not provided.

    "mat": [
    [
    {

    The problem is likey eminating from either the function itself or at the point you are adding to your collections\dictionaries.
    If i was to hazard a guess, i would suggest moving the section below inside the end if, you are probably populating a collection when nothing is found, based on your if statement.

    MTdict.Add "merkmale", MKcoll
    MTcoll.Add MTdict
    MATcoll.Add MTcoll
    Set MKcoll = Nothing
    Set MTdict = Nothing
    Set MTcoll = Nothing





  3. #3
    I'm able to solve the extra square brackets e.g
    "mat": [
    [
    {

    to

    "mat": [
    {

    but not able to bring the two brackets close each other e.g [{

    Below is the long function JSON converter.
    (Sorry, somehow I can't post extra long code, so I zip it)

    JsonConverter.zip


  4. #4
    VBAX Regular arangogs's Avatar
    Joined
    Jun 2009
    Location
    Ayrshire, Scotland
    Posts
    17
    Location
    Hi Chooriang,

    Did you remove the closing ] bracket also?

  5. #5
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,820
    Importing the JSON file into Excel:

    Sub M_snb_import()
        c00 = Replace(Replace(Replace(Replace(CreateObject("scripting.filesystemobject").opentextfile("G:\OF\sigma.json").readall, Chr(34), ""), "\u00df", ""), "\u00fc", ""), "\u00dc", "")
        
        ReDim sp(UBound(Split(c00, vbCrLf)) + 1, 2 * UBound(Split(c00, "[{" & vbCrLf)))
        sn = Split(c00, "[{" & vbCrLf)
        For jj = 0 To UBound(sp, 2) \ 2
           st = Split(sn(jj), vbCrLf)
           For j = 0 To UBound(st)
              If InStr(st(j), "{") + InStr(st(j), "}") = 0 Then
              sv = Split(Trim(st(j)), ":")
              sp(y, jj) = Trim(sv(0))
              If UBound(sv) = 1 Then sp(y, jj + 1) = Trim(sv(1))
              y = y + 1
              End If
           Next
         Next
         
         Cells(20, 1).Resize(UBound(sp), UBound(sp, 2)) = sp
    End Sub
    Export from Excel into JSON file

    Sub M_snb_export()
        sn = Cells(20, 1).CurrentRegion
        
        y = 1
        For j = 1 To UBound(sn)
           c00 = c00 & Space(8 * y) & Chr(34) & sn(j, y) & Chr(34) & ": "
           If sn(j, y + 1) = "" Then
              c00 = c00 & "[{" & vbCrLf
              y = y + 1
            Else
              c00 = c00 & Chr(34) & sn(j, y + 1) & Chr(34) & vbCrLf
            End If
         Next
         c00 = c00 & Replace(Space(y - 1), " ", "}]" & vbCrLf)
         c00 = Replace(Replace(Replace(c00, "", "\u00df"), "", "\u00fc"), "", "\u00dc")
       
         createobject("scripting.filesystemobject").createtextfile("G:\OF\snb.json").write "{" & vbCrLf & c00 & "}"
    End Sub

  6. #6
    Quote Originally Posted by arangogs View Post
    Hi Chooriang, Did you remove the closing ] bracket also?
    Yes, I did.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •