Access multiple exports to existing Excel workbook - excel

Question

I'm using Access 2013 and exporting data to an exisitng Excel 2010 workbook. I'm using the following code (passing the query, worksheet and excel filename). It all works great:
Public Function SendTQ2XLWbSheetSizeRange(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strFilePath is the name and path of the file you want to send this data into.
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Dim strPath As String
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
On Error GoTo err_handler
strPath = strFilePath
Set rst = CurrentDb.OpenRecordset(strTQName)
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Open(strPath)
ApXL.Visible = True
Set xlWSh = xlWBk.Worksheets(strSheetName)
xlWSh.Activate
xlWSh.Range("A5").Select
For Each fld In rst.Fields
ApXL.ActiveCell = fld.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
xlWSh.Range("A6").CopyFromRecordset rst
xlWSh.Range("1:1").Select
' This is included to show some of what you can do about formatting. You can comment out or delete
' any of this that you don't want to use in your own export.
With ApXL.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
ApXL.Selection.Font.Bold = True
With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
' selects all of the cells
ApXL.ActiveSheet.Cells.Select
' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
' selects the first cell to unselect all cells
xlWSh.Range("A1").Select
rst.Close
Set rst = Nothing
Exit_SendTQ2XLWbSheet:
Exit Function
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_SendTQ2XLWbSheet
End Function
Now I have a requirement to export another query to a different workbook within the same Excel file. The problem is the code above opens the Excel file, so if I then call the procedure again, it then opens an additional read-only copy of the Excel. How do I get around this? It total I will need to perform 3 exports to 3 different worksheets within 1 Excel file. Can anyone help?

Answer 1

I'd use three procedures. The first just identifies which file to open and which query goes on which sheet.
This will place Query1 on Sheet1, Query2 on Sheet2. It uses a ParamArray so you can add as many sheet/query pairs as you like:
Public Sub ProcessExcel()
SendToExcel "<full path to Excel file>", "Sheet1", "Query1", "Sheet2", "Query2"
End Sub
The second procedure sets a reference to Excel, opens the workbook and then starts processing the ParamArray. The sheet name is used to create a reference to the actual sheet which is then passed to the next procedure.
Public Sub SendToExcel(sFilePath As String, ParamArray ShtQry() As Variant)
Dim oXL As Object 'Ref to Excel.
Dim oWB As Object 'Ref to workbook.
Dim x As Long 'General counter
'Get or create reference to Excel.
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Err_Handle
Set oXL = CreateObject("Excel.Application")
End If
On Error GoTo Err_Handle
Set oWB = oXL.Workbooks.Open(sFilePath)
For x = LBound(ShtQry) To UBound(ShtQry) Step 2
SendTQ2XLWbSheetSizeRange oWB.worksheets(CStr(ShtQry(x))), CStr(ShtQry(x + 1))
Next x
Exit Sub
Err_Handle:
End Sub
The final procedure opens the recordset and pastes everything onto the correct sheet:
Public Sub SendTQ2XLWbSheetSizeRange(oWrkSht As Object, sTQName As String)
Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim x As Long
Set db = CurrentDb
Set rst = db.OpenRecordset(sTQName)
With oWrkSht
'Place field headings.
For x = 0 To rst.Fields.Count - 1
.cells(5, x + 1) = rst.Fields(x).Name
Next x
'Place values.
.Range("A6").CopyFromRecordset rst
End With
rst.Close
Set rst = Nothing
Set db = Nothing
End Sub
I've missed out plenty of error checks in the code - ensure the sheet exists, that the array holds sheet/query pairs and lots I haven't even considered.
Note: Not a single Select or Activate in sight - just reference the sheet.

Answer 2

This doesn't sound right: 'export another query to a different workbook within the same Excel file'. How about exporting the contents of different tables to one single Excel file, but placing the results of each table to a separate sheet in the same Excel file. You can easily modify the code to export queries to separate Excel sheets, instead of exporting tables.
Option Compare Database
Option Explicit
Private Sub Command0_Click()
Dim strFile As String
Dim varItem As Variant
strFile = InputBox("Designate the path and file name to export to...", "Export")
If (strFile = vbNullString) Then Exit Sub
For Each varItem In Me.List0.ItemsSelected
DoCmd.TransferSpreadsheet transferType:=acExport, _
spreadsheetType:=acSpreadsheetTypeExcel9, _
tableName:=Me.List0.ItemData(varItem), _
FileName:=strFile
Next
MsgBox "Process complete.", vbOKOnly, "Export"
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim strTables As String
Dim tdf As TableDef
' Reference: MS DAO 3.6
' Properties > All > Row Source Type = Value List
For Each tdf In CurrentDb.TableDefs
If (Left(tdf.Name, 4) <> "MSys") Then
strTables = strTables & tdf.Name & ","
End If
Next
strTables = Left(strTables, Len(strTables) - 1)
Me.List0.RowSource = strTables
End Sub
Add a ListBox to a form, and a button on the same form, and run it that way.

Answer 3

Thanks to everyone for their kind words and suggestions. I've gone with #Cody G. 2nd suggestions and just closed the excel file each time, so just adding
xlWBk.Close True
Set xlWBk = Nothing
ApXL.Quit
Set ApXL = Nothing
Each time.