Module to run query then export data

[accessfever]

Hi, I have a super-sized Access table. I created 4 select queries to select data by individual product center from the table: 1 st query to get all data (if the data is not over 50000 lines) and the other 3 queries are to get data by product center (e.g. PL, SG) by product key (some product centers have records over 50K lines).

There are 22 product centers and each center has 3 product keys (B, M, FX) in the Access table. I can determine which product center should use the 1st or the other 3 queries based on the count in the Access table. Since I refresh the Access data once or twice a week, I wanted to have a module to run the select query (queries ) and export data in Excel for all product centers. The filename should include the product center and query's name as well (e.g. PL-product key-all.xls or SG-proudct key-Buy only.xls).

I wonder if there is a simple module to do the tasks above?

 

[boblarson]

Check out my code here -
http://www.btabdevelopment.com/ts/default.aspx?PageId=48
and you don't need to run the queries before exporting them. When you export them, they run with the latest data.

I have other code on my site as well for different requirements around Excel. Just go there and look for CODE SNIPPETS and you'll see a list down the left side when you click on Code Snippets.

What you would do is put that function in a new module (standard module, not form, report or class module) and then name it something other than the function (basExcelExport is good). Then you would use a recordset to pull the departments and such and then iterate through and keep calling that function (you'll probably need to modify the function slightly to save the workbooks, as I just left them open without saving).

 

[accessfever]

Thanks for your codes. I do have a question of where to put the query's critiera to select product center(s) and/or prouct key(s) in your codes. My current way is to run the same queries over and over to export data by 22 product centers so actually I would have splitted the table into at least 22 spreadsheets.

 

[boblarson]

Thanks for your codes. I do have a question of where to put the query's critiera to select product center(s) and/or prouct key(s) in your codes. My current way is to run the same queries over and over to export data by 22 product centers so actually I would have splitted the table into at least 22 spreadsheets.

Okay, something like this. You create a generic query with no criteria for the product center(s) or product key(s) but that would bring back the data you want exported (other than limiting it by those two fields).

Also, you will need to go download and import the basSQLTools module from Access MVP Armen Stein in this database that he has graciously provided. We will need that to perform the ReplaceWhereClause.

Also, down below I will modify the code from my website so you can have it specify the file name and save it. So, you will replace the current SendTQ2Excel with the new version later in this reply (see the red in the code to see what I've changed).

Then you can run this code:

Function ExportPCsPKs() 
   Dim db As DAO.Database
   Dim rstPC As DAO.Recordset
   Dim rstPK As DAO.Recordset
   Dim qdf As DAO.QueryDef
   Dim strOriginalSQL As String
   Dim strFileName As String
 
   Dim strSQL As String
 
  Set db = CurrentDb
  strSQL = "SELECT Distinct ProductCenter FROM YourTableNameHere"
 
  Set rstPC = db.OpenRecordset(strSQL)
 
  strSQL = "SELECT Distinct ProductKey FROM YourTableNameHere"
 
  Set rstPK = db.OpenRecordset(strSQL)
 
        [COLOR=teal]' We will programmatically open the query[/COLOR]
        Set qdf = db.QueryDefs("YourGenericQueryNameHere")
 
[COLOR=teal]       ' saving the original SQL to be able to revert (this may not be necessary in your case[/COLOR]
        strOriginalSQL = qdf.SQL  
 
  Do Until rstPC.EOF
      Do Until rstPK.EOF
[COLOR=teal]       ' setting the where clause we will need (if PC and PK are numeric, leave off the Chr(34) code as those are double quotes for text.[/COLOR]
        strSQL = "WHERE ProductCenter = " & Chr(34) & rstPC!ProductCenter & Chr(34) & " AND ProductKey = " & Chr(34) & rstPK!ProductKey & Chr(34)
 
 
        qdf.SQL = ReplaceWhereClause(qdf.SQL, strSQL)
 
        [COLOR=teal]' set the file name (modify it as you need to fit your needs)[/COLOR]
          strFileName = [URL="file://\\YourServerNameHere\YourShareNameHere\YourFolderNameHere\"]\\YourServerNameHere\YourShareNameHere\YourFolderNameHere\[/URL] & rstPC!ProductCenter & "_" & rstPK!ProductKey & Format(Date(), "yyyymmdd") & ".xls"     
       [COLOR=teal]' next we call the function to export (note the two commas)[/COLOR]
         SendTQ2Excel "YourQueryNameHere", , strFileName
 
         rstPK.MoveNext
      Loop
        rstPC.MoveNext
        rstPK.MoveFirst
  Loop
 
        [COLOR=green]' close the querydef[/COLOR]
        qdf.Close
        Set qdf = Nothing
 
[COLOR=teal] ' Close the recordsets[/COLOR]
  rstPK.Close
  rstPC.Close
 
[COLOR=teal] ' destroy the recordset variables[/COLOR]
  Set rstPK = Nothing
  Set rstPC = Nothing
 
End Function

And the revised code for the SendTQ2Excel

[FONT=courier new]Public Function SendTQ2Excel(strTQName As String, Optional strSheetName As String[COLOR=red], Optional strFileName As String[/COLOR])[/FONT]
[FONT=courier new]' strTQName is the name of the table or query you want to send to Excel[/FONT]
[FONT=courier new]' strSheetName is the name of the sheet you want to name it to[/FONT]
 
[FONT=courier new]   Dim rst As DAO.Recordset[/FONT]
[FONT=courier new]   Dim ApXL As Object[/FONT]
[FONT=courier new]   Dim xlWBk As Object[/FONT]
[FONT=courier new]   Dim xlWSh As Object[/FONT]
[FONT=courier new]   Dim fld As Field[/FONT]
[FONT=courier new]   Const xlCenter As Long = -4108[/FONT]
[FONT=courier new]   Const xlBottom As Long = -4107[/FONT]
 
[FONT=courier new]   On Error GoTo err_handler[/FONT]
 
[FONT=courier new]   Set rst = CurrentDb.OpenRecordset(strTQName)[/FONT]
 
[FONT=courier new]   Set ApXL = CreateObject("Excel.Application")[/FONT]
 
[FONT=courier new]   Set xlWBk = ApXL.Workbooks.Add[/FONT]
 
[FONT=courier new]   ApXL.Visible = True[/FONT]
 
[FONT=courier new]   Set xlWSh = xlWBk.Worksheets("Sheet1")[/FONT]
[FONT=courier new]   If Len(strSheetName) > 0 Then[/FONT]
[FONT=courier new]       xlWSh.Name = Left(strSheetName, 34)[/FONT]
[FONT=courier new]   End If[/FONT]
 
[FONT=courier new]   xlWSh.Range("A1").Select[/FONT]
 
[FONT=courier new]   For Each fld In rst.Fields[/FONT]
[FONT=courier new]       ApXL.ActiveCell = fld.Name[/FONT]
[FONT=courier new]       ApXL.ActiveCell.Offset(0, 1).Select[/FONT]
[FONT=courier new]   Next[/FONT]
 
[FONT=courier new]   rst.MoveFirst[/FONT]
[FONT=courier new]   xlWSh.Range("A2").CopyFromRecordset rst[/FONT]
[FONT=courier new]   xlWSh.Range("1:1").Select[/FONT]
 
[FONT=courier new]   ' This is included to show some of what you can do about formatting.  You can comment out or delete[/FONT]
[FONT=courier new]   ' any of this that you don't want to use in your own export.[/FONT]
[FONT=courier new]   With ApXL.Selection.Font[/FONT]
[FONT=courier new]       .Name = "Arial"[/FONT]
[FONT=courier new]       .Size = 12[/FONT]
[FONT=courier new]       .Strikethrough = False[/FONT]
[FONT=courier new]       .Superscript = False[/FONT]
[FONT=courier new]       .Subscript = False[/FONT]
[FONT=courier new]       .OutlineFont = False[/FONT]
[FONT=courier new]       .Shadow = False[/FONT]
[FONT=courier new]   End With[/FONT]
[FONT=courier new]   ApXL.Selection.Font.Bold = True[/FONT]
[FONT=courier new]   With ApXL.Selection[/FONT]
[FONT=courier new]       .HorizontalAlignment = xlCenter[/FONT]
[FONT=courier new]       .VerticalAlignment = xlBottom[/FONT]
[FONT=courier new]       .WrapText = False[/FONT]
[FONT=courier new]       .Orientation = 0[/FONT]
[FONT=courier new]       .AddIndent = False[/FONT]
[FONT=courier new]       .IndentLevel = 0[/FONT]
[FONT=courier new]       .ShrinkToFit = False[/FONT]
[FONT=courier new]       .MergeCells = False[/FONT]
[FONT=courier new]   End With[/FONT]
[FONT=courier new]   ' selects all of the cells[/FONT]
[FONT=courier new]   ApXL.ActiveSheet.Cells.Select[/FONT]
[FONT=courier new]   ' does the "autofit" for all columns[/FONT]
[FONT=courier new]   ApXL.ActiveSheet.Cells.EntireColumn.AutoFit[/FONT]
[FONT=courier new]   ' selects the first cell to unselect all cells[/FONT]
[FONT=courier new]   xlWSh.Range("A1").Select[/FONT]
 
[FONT=courier new][COLOR=seagreen]   ' If there is a file name, then we save and close it[/COLOR][/FONT]
[FONT=courier new][COLOR=red]   If strFileName <> "" Then[/COLOR][/FONT]
[FONT=courier new][COLOR=red]      xlWBk.SaveAs strFileName[/COLOR][/FONT]
[FONT=courier new][COLOR=red]      ApXL.Quit[/COLOR][/FONT]
[FONT=courier new][COLOR=red]      Set ApXL = Nothing[/COLOR][/FONT]
[FONT=courier new][COLOR=red]   End If[/COLOR][/FONT]
 
[FONT=courier new]   rst.Close[/FONT]
[FONT=courier new]   Set rst = Nothing[/FONT]
[FONT=courier new]   Exit Function[/FONT]
[FONT=courier new]err_handler:[/FONT]
[FONT=courier new]   DoCmd.SetWarnings True[/FONT]
[FONT=courier new]   MsgBox Err.Description, vbExclamation, Err.Number[/FONT]
[FONT=courier new]   Exit Function[/FONT]
[FONT=courier new]End Function[/FONT]

And that should help you on your way (I hope).