I am trying to export the content of an Excel file to a Json file and need the end of line encoding to be LF instead of CRLF.
My pieced together VBA looks like this:
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 = Range("a1:c8")
Set fs = CreateObject("Scripting.FileSystemObject")
' change dir here
Set jsonfile = fs.CreateTextFile("X:\Path\" & "FILE.json", True)
linedata = "["
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
I am grateful for any help or hints!
Use Write instead of Writeline and append a vbLF
jsonfile.Write linedata + vbLF
Related
Very new to SwiftUI and reading data from JSON files, but getting there. Could experts in the community advise please how I get from the data in Excel to the format required in JSON.
In Excel I have this...
... and what I would like from that data in Excel is for my JSON file to be like this...
Could someone advise the steps I'd need to take to get from a to b please. Wondering if this can be done in one step, or if it has to be multiple.
Essentially the code I am writing needs to select 'n' questions from each SylabusItem. So in this example, Question 1 in the exam would need 2 questions presented to the student from a selection of those with the same SylabusItem. So, in this case 2 from 3. Subsequent questions will vary of course.
Thoughts?
Thanks.
You could do that in one step with a VBA function easily enough.
dim dataToWrite(0) 'Normally, I'd dim this as dataToWrite() then use a function to ascertain if empty or not, then either redim(0) or redim preserve (ubound+1) on down. But for succintness just ignoring that.
'Get the lastRow of your data
sheetName1 = activesheet.name 'Obviously change that to whatever suits
LastRow = Sheets(sheetName1).Cells(Sheets(sheetName1).Rows.Count, "A").End(xlUp).Row
for iRow = 2 to lastRow 'Assuming that you have header sheet in first row
if not isempty(Sheets(sheetName1).cells(iRow,1)) then
'Have a Qn entry here
redim preserve dataToWrite(ubound(dataToWrite)+1)
'Do our prefixing
dataToWrite(ubound(dataToWrite)) = "["
redim preserve dataToWrite(ubound(dataToWrite)+1)
dataToWrite(ubound(dataToWrite)) = vbTab & "{"
redim preserve dataToWrite(ubound(dataToWrite)+1)
dataToWrite(ubound(dataToWrite)) = vbTab & vbTab & vbTab & """"Qn"""" & ":" & """" & Sheets(sheetName1).cells(iRow,1) & """"
redim preserve dataToWrite(ubound(dataToWrite)+1)
dataToWrite(ubound(dataToWrite)) = vbTab & vbTab vbTab & & """" & "Level" & """" & ":" & """" & Sheets(sheetName1).cells(iRow,2) & """"
'etc, over to answers, then
corrAnswer = -1
DoUntil IsEmpty(Sheets(sheetName1).cells(iRow,5))
redim preserve dataToWrite(ubound(dataToWrite)+1)
dataToWrite(ubound(dataToWrite)) = vbTab & vbTab & vbTab & """" & "Answer" & Sheets(sheetName1).cells(iRow,5) & """" & ":" & """" & Sheets(sheetName1).cells(iRow,6) & """"
if Sheets(sheetName1).cells(iRow,7) = "y" then
corrAnswer = Sheets(sheetName1).cells(iRow,5)
iRow = iRow + 1
Loop
if corrAnswer = -1 then
'We didn't find a correct answer, problem
else
redim preserve dataToWrite(ubound(dataToWrite)+1)
dataToWrite(ubound(dataToWrite)) = vbTab & vbTab & vbTab & """" & "CorrectAnswer" & """" & ":" & """" & corrAnswer & """"
end if
'And close out
redim preserve dataToWrite(ubound(dataToWrite)+1)
dataToWrite(ubound(dataToWrite)) = vbTab & "},"
next iRow
'Then write out dataToWrite to your text (json) file
Dim filePath As String
filePath = "C:\temp\MyTestFile.txt"
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fileStream As TextStream
Set fileStream = fso.CreateTextFile(filePath)
for iLine = 0 to ubound(dataToWrite)
fileStream.WriteLine dataToWrite(iLine)
fileStream.Close
Thats not complete obviously, and something I've just scribbled down on this page so untested - and likely to have some pythonic stuff in by accident. But should be the bare bones of what you are looking for.
Sorry - forgot your looking the indents. Apply a suitable number of vbTab to the string line,
I got an example from this publication to pass from excel to json, (Is it possible in VBA convert Excel table to json). I didnt change a lot of the code, actually I just add the
RunTimer = Now + TimeValue("00:00:15") Application.OnTime RunTimer, "export_in_json_format"command to keep it running every 15 seconds, the thing is when i got the #N/A value in one cell the code stop running cause the mismatch value, I already tried with one "solution" but instead of manage it and print it in the JSON file it crashed the program and change all the values #N/A for 0 in the code. Any idea, clue that could help me.
Option Explicit
Dim RunTimer As Date
Sub export_to_json()
Dim fs As Object
Dim jsonfile
Dim rangetoexport As Range
Dim rowcounter As Long
Dim columncounter As Long
Dim linedata As String
RunTimer = Now + TimeValue("00:00:15")
Application.OnTime RunTimer, "export_in_json_format"
' change range here
Set rangetoexport = Sheet1.Range("a1:s14")
Set fs = CreateObject("Scripting.FileSystemObject")
' change dir here
Set jsonfile = fs.CreateTextFile("D:\Upload JSON\json_to_firestore\files\" & "Notebook.json", True)
linedata = "["
jsonfile.WriteLine linedata
For rowcounter = 2 To rangetoexport.Rows.Count
linedata = ""
For columncounter = 1 To rangetoexport.Columns.Count
linedata = linedata & """item" & 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
MsgBox "Update done.", vbInformation
End Sub
You need to check each cell value in case it's an error, then decide what to output instead.
Dim v
'...
'...
v = rangetoexport.Cells(rowcounter, columncounter).Value
linedata = linedata & """item" & rangetoexport.Cells(1, columncounter) & """" & ":" & _
"""" & IIf(iserror(v),"Error", v) & """" & ","
'...
'...
Is there a possibility to have the HTML Body:
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
...when criteria > 1 is fulfilled and ...
.HTMLBody = strText2 & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
' in this case the range is missing and the text is different when criteria = 0 is fulfilled.
I thought of the "if" function into the HTML Body?
GetBoiler Function:
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Range function:
Function RangetoHTML(rng As Range)
Dim fso As Object, ts As Object, TempWB As Workbook
With Worksheets("Auswertung")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("$A$7:$D$" & loLetzte).AutoFilter Field:=3, Criteria1:=">0"
If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1). _
SpecialCells(xlCellTypeVisible).Copy
Else
'copy only the strText2
End If
.AutoFilterMode = False
End With
End Function
Main Sub function:
Sub Mail_Klicken()
Dim olApp As Object, datDatum As Date, StrBody As String, intZeile As Integer
Dim OutMail As Object, rng As Range, strMailverteilerTo As String
Dim strText As String, strFilename As String, loLetzte As Long
strMailverteilerTo = "sdfgsdf#gmx.de"
strText = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>hello,<br><br>hello fellows.<br><br>"
strText2 = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>"
Application.DisplayAlerts = True
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.to = strMailverteilerTo
.Subject = "check"
strFilename = "Standard"
If Application.UserName = "asd" Then strFilename = "asd"
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & _
GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & _
strFilename & ".htm")
.Display
End With
Set olApp = Nothing
End Sub
You cant, AFAIK, put a statement like that since its expecting a string argument, here's one way you can do it is to call a function that builds the string,
Set olApp = CreateObject("Outlook.Application")
setStrText criteria, strText, rng
With olApp.CreateItem(0)
'rest of your code
.HTMLBody = strText
'rest of your code
function setStrText(crit as integer, strTe as string, tmpRng as range)
if crit >= 1 then
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>hello,<br><br>hello fellows.<br><br>" & RangetoHTML(tmpRng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
else
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>" & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
end if
end function
I have a Excel Macro that generates monthly reports for multiple clients. I got this code from someone else's question(Is it possible in VBA convert Excel table to json) that was asked here but the code runs only 1 time and generates 1 file every time with the same name. I want to convert the excel sheet into JSON so that i can upload it to Azure Blob.
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 = Sheet2.Range("a2:b6")
Set fs = CreateObject("Scripting.FileSystemObject")
' change dir here
Set jsonfile = fs.CreateTextFile("C:\Users\Satwant\Desktop\" & "MonthlyReport.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
Is there a way to run it multiple times for multiple clients with a unique name ?
replace the line
Set jsonfile = fs.CreateTextFile("C:\Users\Satwant\Desktop\" & "MonthlyReport.json", True)
with
Dim s as string
s = inputbox("Enter Name you want to use")
Set jsonfile = fs.CreateTextFile("C:\Users\Satwant\Desktop\" & s & ".json", True)
to get it to ask you for the file name each time.
I have a situation where i need to place a header line of information into a CSV file.
After which, i will need to append 3 queries, of varying column numbers, to this file.
Currently have this logic, but the TransferText line overwrites what i had placed in the file prior to it:
Dim fldr As String
Dim dlg As Office.FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
.AllowMultiSelect = False
.Title = "Select a Folder:"
.Filters.Clear
'.Filters.Add "CSV Files", "*.csv"
If .show = True Then
fldr = .SelectedItems(1)
End If
End With
GC dlg
'TODO: Remove after Debugging is complete
RaiseAlert "Folder chosen: " & fldr
'-----------------------------------------
Dim file As String
file = fldr & "\Export_DelaGet_" & Format(Now(), "yyyy_mm_dd") & ".csv"
'TODO: Remove after Debugging is complete
RaiseAlert "File: " & file
'-----------------------------------------
'TODO: OpenFile and output the header line
Open file For Output As #1
Print #1, """SYS"",""Some Data""" & vbCrLf
Close 1
'Output Query/View Results to file
DoCmd.TransferText acExportDelim, "MstPrc_Spec", "vwMasterPrices_Output", file, False
Would it be better for me to just Iterate through the query via RecordSet or am i missing something in TransferText?
Unless someone else can provide me a better way of performing this, here is what i have so far.
Dim fldr As String
Dim dlg As Office.FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
.AllowMultiSelect = False
.Title = "Select a Folder:"
.Filters.Clear
'.Filters.Add "CSV Files", "*.csv"
If .show = True Then
fldr = .SelectedItems(1)
End If
End With
GC dlg
'TODO: Remove after Debugging is complete
' RaiseAlert "Folder chosen: " & fldr
'-----------------------------------------
Dim file As String
file = fldr & "\Export_" & Format(Now(), "yyyy_mm_dd") & ".csv"
'TODO: Remove after Debugging is complete
' RaiseAlert "File: " & file
'-----------------------------------------
'TODO: OpenFile and output the header line
Open file For Output As #1
Print #1, """SYS"",""Some Data""" & vbCrLf
Close 1
Open file For Append As #2
Dim rst As DAO.Recordset, str As String
'Append MasterPrices
Set rst = CurrentDb.OpenRecordset("vwMasterPrices_Output")
If rst.RecordCount > 0 Then
Do While Not rst.EOF
str = """" & rst(0) & """,""" & rst(1) & """,""" & rst(2) & """,""" & rst(3) & """,""" & rst(4) & """," & Format(rst(5), "##0.00")
Print #2, str
'Move Next
rst.MoveNext
Loop
End If
'Append GroupPrice
Set rst = CurrentDb.OpenRecordset("vwGroupPrice_Output")
If rst.RecordCount > 0 Then
Do While Not rst.EOF
str = """" & rst(0) & """,""" & rst(1) & """,""" & rst(2) & """," & Format(rst(3), "##0.00")
Print #2, str
'Move Next
rst.MoveNext
Loop
End If
'Append GroupLocations
Set rst = CurrentDb.OpenRecordset("vwGroupLocations_Output")
If rst.RecordCount > 0 Then
Do While Not rst.EOF
str = """" & rst(0) & """,""" & rst(1) & """," & rst(2)
Print #2, str
'Move Next
rst.MoveNext
Loop
End If
GC rst
Close 2
Unfortunately the TransferText method performs a File-Output and not a File-Append operation. So anything in the file prior to the TransferText is cleared and replaced with the output of the method.
Yes i had to have text qualifiers around Strings for the CSV.