Export Sql query to several excel files - mysql

I have 2 tables:
company (rut, name, category, city)
categories (category).
I need to export an excel file for each category with the corresponding companies.
I have the query:
Select * from company c
inner join categories cy on c.category = cy.category;
That is not what I need But each group of combinations is exported to a different excel file.
Thank you.

If you want to export it one by one use this code:
SELECT * FROM COMPANY WHERE CATEGORY = (NAME OF CATEGORY);
If you want to export all:
SELECT * FROM COMPANY ORDER BY CATEGORY ASC;
I dont think you need to join it to "categories" table since you already use the same value from table company.
You can now export your result set.

There are a couple things you can do here.
You can do a big dump to Excel, and copy all unique values in a specific column to a new workbook.
Sub Copy_To_Workbooks()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new workbook"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Set the file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
If ActiveWorkbook.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Delete the sheet RDBLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("RDBLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "RDBLogSheet"
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A3"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A4:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Copy/paste the visible data to the new workbook
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
On Error Resume Next
WSNew.Parent.SaveAs foldername & _
cell.Value & FileExtStr, FileFormatNum
If Err.Number > 0 Then
Err.Clear
ErrNum = ErrNum + 1
WSNew.Parent.SaveAs foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
.Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
.Cells(cell.Row, "A").Interior.Color = vbRed
Else
.Cells(cell.Row, "B").Formula = _
"=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
End If
WSNew.Parent.Close False
On Error GoTo 0
End If
'Show all the data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
.Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
.Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
.Cells(3, "A").Value = "Unique Values"
.Cells(3, "B").Value = "Full Path and File name"
.Cells(3, "A").Font.Bold = True
.Cells(3, "B").Font.Bold = True
.Columns("A:B").AutoFit
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
https://www.rondebruin.nl/win/s3/win006_3.htm
Also, you can split a table/query into several separate Excel files using SSIS. I'm not sure you can do this kind of thing using pure SQL.
I suppose you could use Excel to create queries with where clauses, and filter for all unique records in a table, export each unique batch to worksheet, and then save each worksheet as a separate file. I can imagine that it would run pretty slow on a large table.

Related

Automate Email based on details in spreadsheet and copy/paste tables from spreadsheet into corresponding email

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

How to dynamically pass cell values as a parameter for new PowerQuery?

I created a connection to REST API using PowerQuery in Excel2016 and it gets me information about companies.
In a certain query table, after the results are loaded, there is a column with ID of the company. Now, i want to be able to click on some id and this could be passed to my new query with this id as a parameter in a header. My connection string looks like this:
let
Source = Json.Document(Web.Contents("https://rejestr.io/api/v1/persons/"& Excel.CurrentWorkbook(){[Name="ID"]}[Content]{0}[Column1] &"/relations", [Headers=[Authorization="xxxxxxxxx"]]))
<..rest of the code, mainly formatting...>
in
"ColumnChanged"
Here im referencing the ID from a certain cell (user provided), but i want to be able to pass in this place a value from just selected cell on ID column and then a new query should be created and loaded onto a new worksheet.
I was thinking about this function to "get" a value cell from that column:
Worksheet_SelectionChange(ByVal Target As Range)
But i cannot figure out how to launch a new power query with that...
Alex
Generally, the idea is to avoid manipulating Power Query code directly via VBA (since you cannot be sure the result will be syntactically valid in M).
However, you genuinely seem to want to create a separate new sheet and query each time the user clicks an ID.
I therefore suggest you ignore my previous answer/approach and try the code below. I can't test the code (since I don't have my own credentials for this rejestr.io API) but I think it should work:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
If Intersect(Target.Parent.Range("ID"), Target) Is Nothing Then Exit Sub
' If there is any additional validation required (e.g. if the ID should be numeric,
' or should satisfy some condition/criteria) then it should be done here
' before proceeding to code below.
Dim idSelected As String
idSelected = Target.Value
Dim targetQuery As WorkbookQuery
Set targetQuery = GetOrCreateQueryFromId(idSelected)
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets.Add
Dim targetTable As ListObject
Set targetTable = targetSheet.ListObjects.Add( _
SourceType:=0, _
Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & targetQuery.Name & ";Extended Properties=""""", _
Destination:=targetSheet.Range("$A$1") _
)
With targetTable.QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [" & targetQuery.Name & "]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "_" & targetQuery.Name
.Refresh BackgroundQuery:=False
End With
End Sub
Private Function GetOrCreateQueryFromId(ByVal someId As String) As WorkbookQuery
' Should accept an ID and return the existing WorkbookQuery object.
' If no query for the ID exists, this function should create one (and then
' return the newly created query).
Dim targetQuery As WorkbookQuery
On Error Resume Next
Set targetQuery = ThisWorkbook.Queries(someId)
On Error GoTo 0
Dim queryAlreadyExists As Boolean
queryAlreadyExists = Not (targetQuery Is Nothing)
Dim queryFormula As String
queryFormula = CreateQueryFormulaFromId(someId)
If queryAlreadyExists Then
targetQuery.Formula = queryFormula
Set GetOrCreateQueryFromId = targetQuery
Exit Function
End If
Set GetOrCreateQueryFromId = ThisWorkbook.Queries.Add(Name:=someId, Formula:=queryFormula)
End Function
Private Function CreateQueryFormulaFromId(ByVal someId As String) As String
' Given an ID, should return the Power Query code (code only) required to get data for that ID.
' This function returns the code itself only. It doesn't create the query object.
CreateQueryFormulaFromId = _
"let" & Chr(13) & "" & Chr(10) & _
" Source = Json.Document(Web.Contents(""https://rejestr.io/api/v1/krs/" & someId & "/relations"", [Headers=[Authorization=""x""]]))," & Chr(13) & "" & Chr(10) & _
" #""Converted to Table"" = Table.FromList(Source, Splitter.SplitByNothing(), null, null, ExtraValues.Error), " & Chr(13) & "" & Chr(10) & _
" #""Expanded Column1"" = Table.ExpandRecordColumn(#""Converted to Table"", ""Column1"", {""address"", ""business_insert_date"", ""ceo"", ""current_relations_count"", ""data_fetched_at"", ""first_entry_date"", ""historical_relations_count"", ""id"", ""is_opp"", ""is_removed"", ""krs"", ""last_entry_date"", ""last_entry_no"", ""last_state_entry_date"", ""last_state_entry_no"", ""legal_form"", ""name"", ""name_short"", ""nip"", ""regon"", ""type"", ""w_likwidacji"", ""w_upadlosci"", ""w_zawieszeniu"", ""relations"", ""birthday"", ""first_name"", ""krs_person_id"", ""last_name"", ""organizations_count"", ""second_names"", ""sex""}, " & _
"{""Column1.address"", ""Column1.business_insert_date"", ""Column1.ceo"", ""Column1.current_relations_count"", ""Column1.data_fetched_at"", ""Column1.first_entry_date"", ""Column1.historical_relations_count"", ""Column1.id"", ""Column1.is_opp"", ""Column1.is_removed"", ""Column1.krs"", ""Column1.last_entry_date"", ""Column1.last_entry_no"", ""Column1.last_state_entry_date"", ""Column1.last_state_entry_no"", ""Column1.legal_form"", ""Column1.name"", ""Column1.name_short"", ""Column1.nip"", ""Column1.regon"", ""Column1.type"", ""Column1.w_likwidacji"", ""Column1.w_upadlosci"", ""Column1.w_zawieszeniu"", ""Column1.relations"", ""Column1.birthday"", ""Column1.first_name"", ""Column1.krs_person_id"", ""Column1.last_name"", ""Column1.organizations_count"", ""Column1.second_names"", ""Column1.sex""})" & Chr(13) & "" & Chr(10) & _
"in" & Chr(13) & "" & Chr(10) & _
" #""Expanded Column1"""
End Function
If that is a genuine API key/credential in your question, then you may want to have the server provider revoke/change it (so that nobody can consume this service API using your credentials).
There is no error handling implemented and currently the user's input is not validated/sanitised in any way.
Hi I implemented your method. However i encountered 2 problems:
When I run the macro when im clicking on defined range and query is added, range is being "shortened" to only the field i just clicked on. So the "idselected" instead of A2:A10 now becames just A2...
The query is sucessfully added and parameter is succesfully passed but when i ran the query and the new sheet is added, the error occurs:
"The worksheet data for a table needs to be on the same sheet as the table"
My final VBA code looks like this now:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
If Intersect(Target.Parent.Range("Range5"), Target) Is Nothing Then Exit Sub
With ThisWorkbook
.Names("Range5").RefersTo = Target
.Queries.Add Name:="2-1_1", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Json.Document(Web.Contents(""https://rejestr.io/api/v1/krs/"" & Excel.CurrentWorkbook(){[Name=""Range5""]}[Content]{0}[Column1] & ""/relations"", [Headers=[Authorization=""xxxxxxx""]]))," & Chr(13) & "" & Chr(10) & " #""Converted to Table"" = Table.FromList(Source, Splitter.SplitByNothing(), null, null, ExtraValues.Error), " & Chr(13) & "" & Chr(10) & " #""Expanded Column1"" = Table.ExpandRecordColumn(#""Con" & _
"verted to Table"", ""Column1"", {""address"", ""business_insert_date"", ""ceo"", ""current_relations_count"", ""data_fetched_at"", ""first_entry_date"", ""historical_relations_count"", ""id"", ""is_opp"", ""is_removed"", ""krs"", ""last_entry_date"", ""last_entry_no"", ""last_state_entry_date"", ""last_state_entry_no"", ""legal_form"", ""name"", ""name_short"", ""nip"", ""regon"", ""type"", ""w_likwidacji"", ""w_upadlo" & _
"sci"", ""w_zawieszeniu"", ""relations"", ""birthday"", ""first_name"", ""krs_person_id"", ""last_name"", ""organizations_count"", ""second_names"", ""sex""}, {""Column1.address"", ""Column1.business_insert_date"", ""Column1.ceo"", ""Column1.current_relations_count"", ""Column1.data_fetched_at"", ""Column1.first_entry_date"", ""Column1.historical_relations_count"", ""Column1.id"", ""Column1.is_opp"", ""Column1.is_rem" & _
"oved"", ""Column1.krs"", ""Column1.last_entry_date"", ""Column1.last_entry_no"", ""Column1.last_state_entry_date"", ""Column1.last_state_entry_no"", ""Column1.legal_form"", ""Column1.name"", ""Column1.name_short"", ""Column1.nip"", ""Column1.regon"", ""Column1.type"", ""Column1.w_likwidacji"", ""Column1.w_upadlosci"", ""Column1.w_zawieszeniu"", ""Column1.relations"", ""Column1.birthday"", ""Column1.first_name"", ""Column1.krs_person_id"", ""Column1.last_name"", ""Column1.organizations_count"", ""Column1.second_names"", ""Column1.sex""})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Expanded Column1"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=2-1_1;Extended Properties=""""" _
, Destination:=Range("$S$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [2-1_1]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "_2_1_1"
.Refresh BackgroundQuery:=False
End With
End With

Error 1004 when pulling table with ActiveWorkbook.Queries.Add

I'm trying to create a quick way to pull financial statements (a basic table) from yahoo finance (e.g. https://finance.yahoo.com/quote/FB/financials?p=FB) with VBA.
I'm a complete noob so I used the record macro tool and Get data from web and tried (with my non-existent VBA knowledge) to adapt it to use a variable (Ticker) to change the company.
When using the get data from web function the table is imported perfectly but it doesn't work with VBA code. I get 1004 error about either ListObject.DisplayName or Refresh BackgroundQuery
Sub Macro5()
Dim Ticker As String
Ticker = InputBox("Ticker")
ActiveWorkbook.Queries.Add Name:="Table" & Ticker, Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Web.Page(Web.Contents(""https://finance.yahoo.com/quote/& Ticker &/financials?p=&Ticker &""))," & Chr(13) & "" & Chr(10) & " Data2 = Source{2}[Data]," & Chr(13) & "" & Chr(10) & " #""Type modifié"" = Table.TransformColumnTypes(Data2,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}, {""Column5"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Type modifié"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Extended Properties=""""" _
, Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [Table & Ticker")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "Table" & Ticker
.Refresh BackgroundQuery:=False
End With
End Sub
The idea is to output the Income Statement form for the "Ticker" (FB in my exemple).
I'm using Excel 365 on windows
Thanks a lot
An easy method is to grab all the table elements on the page and loop those using clipboard to copy paste to sheet. You can adapt to write to different sheets based on ticker value. Use a loop over tickers to retrieve data but ensuring you create the ie object before the loop and then have the navigate2 within the loop so as to visit each new ticker page.
Public Sub GetTables()
Dim clipboard As Object, ws As Worksheet, j As Long, tables As Object
Dim ie As Object, ticker As String
ticker = "FB"
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Cells.UnMerge
ws.Cells.ClearContents
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Application.ScreenUpdating = False
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.Navigate2 "https://finance.yahoo.com/quote/FB/financials?p=" & ticker
While .Busy Or .readyState < 4: DoEvents: Wend
Set tables = .document.querySelectorAll("table")
For j = 0 To tables.Length - 1
clipboard.SetText tables.item(j).outerHTML
clipboard.PutInClipboard
ws.Cells(LastRow(ws) + 2, 1).PasteSpecial
Next
.Quit
End With
Application.ScreenUpdating = True
End Sub
'https://www.rondebruin.nl/win/s9/win005.htm
Public Function LastRow(ByVal sh As Worksheet) As Long
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
This second method is rather a leap in knowledge for you, but maybe useful in future and to other readers. You can extract all the info on the page from a script tag. With some string splitting on the innerHTML of that script element you can get a string which a json parser can handle. You can then parse the json for whatever info you want. I include an outline only below.
Option Explicit
'VBE > Tools > References:
' Microsoft Internet Controls
' Microsoft Scripting Runtime
'Download and add in jsonconverter.bas from https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas
Public Sub GetYahooData()
Dim IE As New InternetExplorer, ticker As String
ticker = "FB"
With IE
.Visible = True
.Navigate2 "https://finance.yahoo.com/quote/FB/financials?p=" & ticker
While .Busy Or .readyState < 4: DoEvents: Wend
Dim script As Object, scripts As Object, i As Long, extract As String, json As Object
Set scripts = .document.querySelectorAll("script")
For i = 0 To scripts.Length - 1
If InStr(1, scripts.item(i).innerHTML, "/* -- Data -- */") Then
Set script = scripts.item(i)
Exit For
End If
Next
If Not script Is Nothing Then
extract = Split(Split(script.innerHTML, "root.App.main = ")(1), "(this));")(0)
extract = Left$(extract, InStrRev(extract, ";") - 1)
Set json = JsonConverter.ParseJson(extract)("context")("dispatcher")("stores")("QuoteSummaryStore")("cashflowStatementHistory")
End If
If Not json Is Nothing Then
'parse json for data of interest
End If
Stop ' <== Delete me later
.Quit
End With
End Sub
There is simply too much info in the json to go through it all but here is a snapshot extract of the webpage on the left, and the json which relates to it on the right:
I tried to workout solution on your adopted code. Your table of interest is Table 2 on the page when we retrieve the URL through Excel Data Tab from web. We have to tackle two problems .
Table reference is proper. As we run the program number of times query table name is in Excel memory and is not removed even after deleting the sheet. So I have to increment table index like [Table 2 (2)] then next time [Table 2 (3)] at 3 places in the code. If we increment table index every time program will run correctly.To find out what is the index number of table ListTables() sub routine will help. I could not find a suitable way that Excel do not remember table index of a deleted sheet table.
Second necessary point is to close connection. I have added suitable code for the same.
Final code works out as following.
Sub Macro7()
'
' Macro1 Macro
'
'
Dim Cn As Variant
Dim Ticker As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ticker = InputBox("Ticker")
ActiveWorkbook.Queries.Add Name:="Table 2 (18)", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Web.Page(Web.Contents(""https://finance.yahoo.com/quote/" & Ticker & "/financials?p=" & Ticker & """))," & Chr(13) & "" & Chr(10) & " Data2 = Source{2}[Data]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Data2,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}, {""Column5"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Changed Type"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 2 (2)"";Extended Properties=""""" _
, Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [Table 2 (18)]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "Table_2__18"
.Refresh BackgroundQuery:=False
End With
'Range("A16").Select
For Each Cn In ThisWorkbook.Connections
Cn.Delete
Next Cn
For Each Cn In ActiveSheet.QueryTables
Cn.Delete
Next Cn
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
And code routine for listing table index is:
Sub ListTables()
Dim xTable As ListObject
Dim xSheet As Worksheet
Dim I As Long
I = -1
Sheets.Add.Name = "Table Name"
For Each xSheet In Worksheets
For Each xTable In xSheet.ListObjects
I = I + 1
Sheets("Table Name").Range("A1").Offset(I).Value = xTable.Name
Sheets("Table Name").Range("B1").Offset(I).Value = xSheet.Name
Next xTable
Next
End Sub

how i can merge multi pdfs files by using VBA code

I have a table that contains a paths of multi pdfs file...now I need a VBA code to merge all these files to a single pdf file.
Notice:-the number of pdfs files to be merged varies from time to time.
Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
RS.Close
Set RS = Nothing`enter code here`
public Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDFs = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDFs = False
End If
On Error GoTo 0
End Function
This uses a list of PDF or PS files to create one PDF. Sorry it's in VB.net and I don't really have time to convert. But it illustrates the concept if you can wade through it. Basically you write the options and file names to a text file then use that file as an argument to Ghostscript.
Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
ByVal PDFPathName As String, _
ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)
'check that all files exist
PSPathFileList.ForEach(AddressOf CheckFiles)
'check old pdf file
If IO.File.Exists(PDFPathName) Then
Throw New ApplicationException( _
"PDF cannot be created. File already exists: " & PDFPathName)
End If
'convert engine
Dim myProcInfo As New ProcessStartInfo
myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
Debug.Print(myProcInfo.FileName)
'write file names to text file as the list can be very long
Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"
Dim ft As New StreamWriter(fiName2)
ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
For i As Long = 0 To PSPathFileList.Count - 1
ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
Next
ft.Close()
'set args to text file
myProcInfo.Arguments = """#" & fiName2 & """"
'set up for output and errors
myProcInfo.UseShellExecute = False
myProcInfo.RedirectStandardOutput = True
myProcInfo.RedirectStandardError = True
Debug.Print(myProcInfo.Arguments)
'do the conversion
Dim myProc As Process = Process.Start(myProcInfo)
Debug.Print(myProc.StandardOutput.ReadToEnd)
Debug.Print(myProc.StandardError.ReadToEnd)
If WaitForExit Then
'wait for finish; (no more than 60 seconds)
myProc.WaitForExit(60000)
'delete PS
If DeletePS Then
PSPathFileList.ForEach(AddressOf DeleteFiles)
End If
End If
End Sub
Here's VBA code for a single PS to PDF. So between the VB.net above and this below hopefully you can salvage something useful.
Private Sub printToPdfDemo()
'verify printer setup
'be sure to install the PsPrinterInstall module
Call PSPrinterSetup
Dim svPsFileName As String
Dim svPDFName As String
'define names
svPsFileName = "C:\Temp\Input 1.ps"
svPDFName = "C:\Temp\Output 1.PDF"
'save current printer
Dim PrinterInUse As String
PrinterInUse = Application.ActivePrinter
'print to PS
'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
PrToFileName:=svPsFileName
'revert to saved printer name
Application.ActivePrinter = PrinterInUse
'convert
Call ConvertToPDF(svPsFileName, svPDFName)
End Sub
Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
Dim fso As New FileSystemObject
'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim folGS As Folder
Dim lcCmd As String
'check inputs
If svPsFileName = "" Or svPDFName = "" Then
Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
Exit Sub
End If
'check file
If Not fso.FileExists(svPsFileName) Then
Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
Exit Sub
End If
'check variable
If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation
'delete old file
If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)
'get files
Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE
'GS command
lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
"-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
"-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
"-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
& " -dBATCH " & """" & svPsFileName & """"
'convert
Debug.Print lcCmd
Call ShellWait(lcCmd)
'delete PS
If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)
End Sub

How to freeze panes of output worksheet

I currently have some VBA code written in Access to output an Excel file. Right now, there is no formatting assigned to the spreadsheet, only the raw data that is pulled using the query I created. My questions is, how do I go about freezing the top row of the outputted spreadsheet? See my code below.
Option Compare Database
Public TimeStamp As String
Public TimeStamp2 As String
Function DailyMTDMail()
If Weekday(Date) = 7 Or Weekday(Date) = 1 Then
'do nothing
Else
TimeStamp = Month(Date) & "." & Day(Date) & "." & Year(Date)
DoCmd.OutputTo acOutputQuery, "001 Extract Sales in Period",
acFormatXLSX, "\\xxx\xxx\xxx\MTD Sales # " & TimeStamp & ".xlsx", False
Dim filename As String
filename = "\\xxx\xxx\xxx\MTD Sales # " & TimeStamp & ".xlsx"
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set xl = CreateObject("Excel.Application")
Set wb = xl.Workbooks.Open(filename)
Set ws = wb.Sheets("001 Extract Sales in Period") ' change to
the name of your sheet
wb.Application.ActiveWindow.FreezePanes = False
ws.Range("a2").Select ' change to the range you want to
freeze
wb.Application.ActiveWindow.FreezePanes = True
wb.Save
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = " Inc - MTD Sales # " & TimeStamp
objMessage.From = "email#email.com"
'objMessage.To = "email#email.com"
objMessage.To = "email#email.com" 'test
objMessage.Textbody = "Please find attached MTD sales # " & TimeStamp &
vbCr & vbCr & "Regards" & vbCr & vbCr & "Name"
objMessage.AddAttachment filename
'This section provides the configuration information for the remote SMTP
server.
'Normally you will only change the server name or IP.
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"word"
'Server port (typically 25)
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
'End remote SMTP server configuration section==
objMessage.Send
End If
After the docmd.outputto you have to open the excelfile, freeze at the cell you want, save and close the file, as example:
Function FreezeMe(strfile As String)
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set xl = CreateObject("Excel.Application")
Set wb = xl.Workbooks.Open(strfile)
Set ws = wb.Sheets("sheet1") ' change to the name of your sheet
wb.Application.ActiveWindow.FreezePanes = False
ws.Range("a2").Select ' change to the range you want to freeze
wb.Application.ActiveWindow.FreezePanes = True
wb.Save
wb.Close
End Function