chooriang
12-07-2019, 12:37 AM
I'm trying to re-create JSON file by using Excel VBA and Tim Hall's Excel JSON classes. (https://github.com/VBA-tools/VBA-JSON)
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
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