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,
Related
Thank you for taking the time to try and help me with this project.
I have some vba that sends an email to each recipient on my spreadsheet and includes in the body of the text information from the spreadsheet. This piece of the code works great. Here's the part where I am stuck...
The workbook contains a couple tables that I would like to filter and copy/paste into each email BUT the data from each table needs to be filtered to the data that applies to each recipient.
For example:
The email is being sent to a Regional leader and includes scores for their Region overall.
I have 1 table that includes manager scores which can be filtered by Region and
on a second tab, I have a table for each Region that drills down the scores by type of service.
So for the SouthWest Regional leader, I would like to Filter table 1 to only show managers in the SouthWest Region, copy/paste that table directly into the email and then go to the Service Type tables and copy the SouthWest table and paste into the email.
The final piece I would like to accomplish is to copy the employee level details which reside on a separate tab, to a workbook and attach it to the email. This too would need to be specific to employees within each region.
I don't know if this is possible within my code or if there is a smart way to accomplish it. I appreciate any help or insight you are willing to give! I have attached an example file and below is the email code I am currently using. I also have some code that filters the data based on the region that may or may not be helpful.
Sub SendMailtoRFE()
Dim outapp As New Outlook.Application
Dim outmail As Outlook.Mailitem
Dim wks As Worksheet
Dim i As Integer
Dim sFile1 As String
Dim TempFilePath As String
Environ ("UserProfile")
Set outapp = CreateObject("outlook.application")
sFile1 = "Infographic"
TempFilePath = Environ$("temp") & "Roadside Assistance " 'FIND OUT HOW TO CLEAN UP THE NAME: "Temp" added to file name
ActiveWorkbook.Sheets(sFile1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sFile1 & ".pdf"
On Error Resume Next
For i = 3 To wks.Range("A" & Rows.Count).End(xlUp).Row
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.To = wks.Range("C" & i).Value
.Subject = wks.Range("A" & i).Value & " Region Roadside Assistance YTD Communication"
.HTMLBody = "Dear " & wks.Range("C" & i).Value & "," & "<br></br>" & _
"You've shared how important Roadside Assistance is for your personal auto clients. As one of the highest frequency types of losses, success or failure " & _
"here may be seen as a signal of the overall value of the program." & "<br></br><br></br>" & _
"Here are the results for clients in your area who completed a survey. Year to date, the NPS was " & FormatPercent(wks.Range("K" & i).Value, 0) & _
" based on " & wks.Range("H" & i).Value & " total responses." & _
" The overall score for all regions is " & FormatPercent(wks.Range("K12").Value, 0) & "." & "<br></br><br></br>" & _
"Below are a few additional details to help you understand your region's score. " & _
"Please follow up with any questions or concerns." & "<br></br><br></br>" & vbNewLine & _
"**Please note, the table containing MLGA scores shows only the MLGA's where 5 or more survey responses were received.**"
.Attachments.Add (TempFilePath & sFile1 & ".pdf")
.display
End With
On Error GoTo 0
Set outmail = Nothing
Next i
Set outapp = Nothing
End Sub
''Filter Region on the MLGA Tow NPS Score Tab
Sub FilterSouthWest()
Dim wks As Worksheet
Set wks = Sheets("MLGA TOW NPS Score")
With wks.Range("A2:C2")
.AutoFilter Field:=3, Criteria1:="9A"
End With
End Sub
Use .SpecialCells(xlCellTypeVisible) to set the range on the filtered table and copy/paste them into the email using WordEditor. To insert the html text create a temporary file and use .InsertFile, This converts the html formatting into word formatting. You may need to add a wait between the copy/paste action depending on the amount of data.
Option Explicit
Sub SendMailtoRFE()
'sheet names
Const PDF = "Infographic" ' attachment
Const WS_S = "MLGA TOW NPS Score" ' filtered score data
Const WS_R = "Regions" ' names and emails
Const WS_T = "Tables" ' Regions Tables
Dim ws As Worksheet, sPath As String, sPDFname As String
Dim lastrow As Long, i As Long, n As Long
' region code for filter
Dim dictRegions As Object, region
Set dictRegions = CreateObject("Scripting.Dictionary")
With dictRegions
.Add "NorthEast", "6A"
.Add "NorthWest", "7A"
.Add "SouthEast", "8A"
.Add "SouthWest", "9A"
End With
sPath = Environ$("temp") & "\"
sPDFname = sPath & "Roadside Assistance " & PDF & ".pdf"
Sheets(PDF).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPDFname
Dim outapp As Outlook.Application
Dim outmail As Outlook.Mailitem
Dim outInsp As Object, oWordDoc
Dim wsRegion As Worksheet
Dim sRegion As String, sEmailAddr As String, rngScore As Range
Dim Table1 As Range, Table2 As Range, tmpHTML As String
' scores
With Sheets(WS_S)
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngScore = .Range("A2:G" & lastrow) ' 5 columns
End With
' open outlook
Set outapp = New Outlook.Application
' regions
Set wsRegion = Sheets(WS_R)
lastrow = wsRegion.Cells(wsRegion.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastrow '
sRegion = wsRegion.Range("A" & i).Value
sEmailAddr = wsRegion.Range("C" & i).Value
tmpHTML = HTMLFile(wsRegion, i)
' region
With rngScore
.AutoFilter
.AutoFilter Field:=3, Criteria1:=dictRegions(sRegion) ' filter col C
Set Table1 = .SpecialCells(xlCellTypeVisible)
End With
' Service Type Table
Set Table2 = Sheets(WS_T).ListObjects(sRegion).Range ' Table named same as region
'Debug.Print dictRegions(sRegion), sRegion, Table1.Address, Table2.Address
Set outmail = outapp.CreateItem(olMailItem)
n = n + 1
With outmail
.To = sEmailAddr
.Subject = sRegion & " Region Roadside Assistance YTD Communication"
.Attachments.Add sPDFname
.display
End With
Set outInsp = outmail.GetInspector
Set oWordDoc = outInsp.WordEditor
'Wait 1
With oWordDoc
.Content.Delete
.Paragraphs.Add.Range.InsertFile tmpHTML, Link:=False, Attachment:=False
Table1.Copy
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = vbCrLf ' blank line
'Wait 1
Table2.Copy
.Paragraphs.Add.Range.Paste
'Wait 1
End With
Application.CutCopyMode = False
Set oWordDoc = Nothing
Set outInsp = Nothing
Set outmail = Nothing
' delete temp html file
On Error Resume Next
Kill tmpHTML
On Error GoTo 0
'Wait 1
Next
' end
Sheets(WS_S).AutoFilterMode = False
Set outapp = Nothing
AppActivate Application.Caption ' back to excel
MsgBox n & " Emails created", vbInformation
End Sub
Function HTMLFile(ws As Worksheet, i As Long) As String
Const CSS = "p{font:14px Verdana};h1{font:14px Verdana Bold};"
' template
Dim s As String
s = "<html><style>" & CSS & "</style><h1>Dear #NAME#,</h1>" & _
"<p>You've shared how important Roadside Assistance is for your personal auto clients.<br/>" & vbLf & _
"As one of the highest frequency types of losses, success or failure " & vbLf & _
"here may be seen as a signal of the overall value of the program.</p>" & vbLf & _
"<p>Here are the results for clients in your area who completed a survey.</p> " & vbLf & _
"<li>Year to date, the NPS was <b>#NPS_YTD#</b> " & vbLf & _
"based on <b>#RESPONSES#</b> total responses.</li> " & vbLf & _
"<li>The overall score for all regions is <b>#NPS_ALL#</b>,</li>" & vbLf & _
"<p>Below are a few additional details to help you understand your region's score. " & vbLf & _
"Please follow up with any questions or concerns." & "</p>" & vbNewLine & vbLf & _
"<p><i>**Please note, the table containing MLGA scores shows only the MLGA's where 5 " & vbLf & _
"or more survey responses were received.**</i></p></html>"
s = Replace(s, "#NAME#", ws.Cells(i, "C"))
s = Replace(s, "#NPS_YTD#", FormatPercent(ws.Cells(i, "K"), 0))
s = Replace(s, "#RESPONSES#", ws.Cells(i, "H"))
s = Replace(s, "#NPS_ALL#", FormatPercent(ws.Cells(12, "K"), 0))
Dim ff: ff = FreeFile
HTMLFile = Environ$("temp") & "\" & Format(Now(), "~yyyymmddhhmmss") & ".htm"
Open HTMLFile For Output As #ff
Print #ff, s
Close #ff
End Function
Sub Wait(n As Long)
Dim t As Date
t = DateAdd("s", n, Now())
Do While Now() < t
DoEvents
Loop
End Sub
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) & """" & ","
'...
'...
I am trying to upload a file on HTML page, for which I need to run the vbascript saved on my desktop. But when I am executing the code its asking for admin permission and getting error as "Access Denied". So is there any way to run this file without but it should not break any policy and as I don't want to create any security issue.
Thanks in advance:)
Sub uploadFiles()
Dim ie As Object
Dim strFile As Variant
Dim strUploadFile As Variant
Dim objShell As Variant
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "https://www.pdftoexcelconverter.net/"
ie.Visible = True
Application.Wait DateAdd("s", 5, Now)
strFile = "C:\Users\kiranm\Desktop\2019\FileUpload.vbs"
strUploadFile = "C:\Users\kiranm\Desktop\2019\fl0005.pdf"
Dim R_Shl As Double
Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34) & strUploadFile & Chr(34)
ie.document.getElementsByName("Filedata")(0).Click
Application.Wait DateAdd("s", 2, Now)
End Sub
Here is how
Chr(34) & strFile & Chr(34) & strUploadFile & Chr(34)
really looks like (this is from your code): "C:\Users\kiranm\Desktop\2019\FileUpload.vbs"C:\Users\kiranm\Desktop\2019\fl0005.pdf"
As you see, there are not enough double quotes and spaces.
And here is how
"wscript.exe" & strFile & " " & strUploadFile
look like (this is from your comment)
wscript.exeC:\Users\kiranm\Desktop\2019\FileUpload.vbs C:\Users\kiranm\Desktop\2019\fl0005.pdf
So, I would have tried to use this version:
Chr(34) & strFile & Chr(34) & " " & Chr(34) & strUploadFile & Chr(34)
in the code in post.
I have a split access database. The tables which reside in the backend have "Before Change" macros built into them (in the backend). I need to overwrite these macros with new ones. I have an XML file of the updated macro and am trying to use the code below to overwrite the macros. However, the code below puts the macro on my linked table in the frontend. I need the macro to update the macro on the table in the backend. Any and all help is much appreciated.
LoadFromText acTableDataMacro, "tblEXAMPLE", strXMLpath
I figured out how to do this.
Dim fso As Object
Dim oFile As Object
Dim strXML As String
Dim strXMLpath As String
Dim strBE As String
Dim accessApp As Access.Application
strXML = "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-16" & Chr(34) & " standalone=" & Chr(34) & "no" & Chr(34) & "?>" & _
"<DataMacros xmlns=" & Chr(34) & "http://schemas.microsoft.com/office/accessservices/2009/11/application" & Chr(34) & "><DataMacro Event=" & Chr(34) & "BeforeChange" & Chr(34) & "><Statements><ConditionalBlock><If>"
strXMLpath = Application.CurrentProject.Path & "\XML_File.xml"
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFile = fso.CreateTextFile(strXMLpath)
oFile.WriteLine strXML
oFile.Close
Set fso = Nothing
Set oFile = Nothing
strBE = CurrentDb.TableDefs("TableName").Connect
strBE = Replace(strBE, ";Database=", "")
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase strBE, True
accessApp.LoadFromText acTableDataMacro, "TableName", strXMLpath
Kill strXMLpath
strQuery = _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\Source1.xlsx' " & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;ExtendedProperties='HDR=YES;'] " & _
"UNION " & _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\Source2.xlsx' " & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'] " & _
"UNION " & _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\Source3.xlsx' " & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'] " & _
"ORDER BY A;"
Good morning,
I have one last nail to go on this coding I have and any help is much appreciated. I am gathering numerous files from a single folder and file names are different (although data order and data are same).
Question is:
Is it possible to get all files via the 'strQuery' without slowing down the code? How do I go on to do this? (eg: I think maybe loop but it might slow down? - see below)
Is it possible to get (say) 100 excel file data read at once? (although I do not know names of it?)
I can modify strQuery (via assigning it a text string) and input a loop to go through every file but I recon this would require me to create a connection for every single file rather than all at once?
Any help is appreciated!
Thanks in advance.
--
Full Code below (I didn't know where to put this in a visible manner)
Sub SqlUnionTest()
Dim strConnection As String
Dim strQuery As String
Dim objConnection As Object
Dim objRecordSet As Object, qText As String
strConnection = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"User ID=Admin;" & _
"Data Source='" & ThisWorkbook.FullName & "';" & _
"Mode=Read;" & _
"Extended Properties=""Excel 12.0 Macro;"";"
Dim sFile As String
sFile = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While sFile <> ""
strQuery = _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\" & sFile & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;ExtendedProperties='HDR=YES;'] " & _
"UNION "
sFile = Dir()
Loop
strQuery = Left(strQuery, Len(strQuery) - 7) 'to remove last UNION which is not necessary
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open strConnection
Set objRecordSet = objConnection.Execute(strQuery)
RecordSetToWorksheet Sheets(1), objRecordSet
objConnection.Close
End Sub
Sub RecordSetToWorksheet(objSheet As Worksheet, objRecordSet As Object)
Dim i As Long
With objSheet
.Cells.Delete
For i = 1 To objRecordSet.Fields.Count
.Cells(1, i).Value = objRecordSet.Fields(i - 1).Name
Next
.Cells(2, 1).CopyFromRecordset objRecordSet
.Cells.Columns.AutoFit
End With
End Sub
You can use the DIR() function to loop through all the .xlsx files in the folder without knowing the specific file names. If you need to weed out any files, you can place conditional testing inside the loop.
Code untested
Dim sFile As String, strQuery As String
sFile = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While sFile <> ""
strQuery = strQuery & _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\" & sFile & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;ExtendedProperties='HDR=YES;'] " & _
"UNION;"
sFile = Dir()
Loop
strQuery = Left(strQuery, Len(strQuery) - 7) 'to remove last UNION which is not necessary