The following code is used to essentially export queries to excel with some light formatting. There's about a 50/50 mix, where some of these queries are exported to an existing excel template, and the rest go to a fresh workbook. There is certainly room for optimization in the code for the later half, but would I just be better off using a DoCmd.Transferspreadsheet for those instead? For reference, this gets referenced a few hundred times during month end reporting, so not sure if the optimization would make a dent in the processing time, or if I should spend my time focusing on the bulk queries.
Code:
Option Compare Database
Option Explicit
'Exporting DAO to Excel with some basic formatting. Will overwrite if file already exists to preserve any data connections
'Sheet names are not case sensitive, and support spacing
'
Public Sub OutXL_Mult(strQueryName As String, strExportPath As String, strSheetName As String)
Const strcCellAddress As String = "A1"
Dim objExcel As Object
Dim objWB As Object
Dim objWS As Object
Dim objRNG As Object
Dim SaveArray() As String
Dim SaveFormat As Long
Dim objDB As DAO.Database
Dim objRS As DAO.Recordset
Dim objQry As DAO.QueryDef
Dim i As Integer
Dim prm As Variant
Dim Exists As Boolean
Set objDB = CurrentDb
Set objQry = objDB.QueryDefs(strQueryName)
'pulls dates from form
For Each prm In objQry.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set objRS = objQry.OpenRecordset(Options:=dbSeeChanges)
'***Open and define Excel objects***
Set objExcel = CreateObject("Excel.Application")
'Check to see if WB exists
If Dir(strExportPath) = "" Then
Set objWB = objExcel.Workbooks.Add
Else
Set objWB = objExcel.Workbooks.Add(strExportPath)
End If
'Check to see if WS exists
For i = 1 To objWB.Worksheets.Count
If objWB.Worksheets(i).Name = strSheetName Then
Exists = True
End If
Next i
If Not Exists Then
objWB.Worksheets.Add.Name = strSheetName
End If
Set objWS = objWB.Worksheets(strSheetName)
Set objRNG = objWS.Range(strcCellAddress)
'Calling data in from recored set
'Clear sheet of current data
objWS.UsedRange.Clear
'Headers
For i = 1 To objRS.Fields.Count
objWS.Cells(1, i).Value = objRS.Fields(i - 1).Name
Next i
'Recordset
objWS.Cells(2, 1).CopyFromRecordset objRS
'***Formatting***
With objWS
.Cells.Font.Name = "Calbri"
.Range(strcCellAddress, objWS.Range(strcCellAddress).End(-4161)).Interior.ColorIndex = 15
End With
objWS.Cells.EntireColumn.AutoFit
'Version Check
SaveArray() = Split(strExportPath, ".")
If SaveArray(1) = "xls" Then
SaveFormat = 56
Else
SaveFormat = 51
End If
'Close and release
objExcel.DisplayAlerts = False
objWB.RefreshAll 'For pivot table updates
objWB.SaveAs FileName:=strExportPath, FileFormat:=SaveFormat, ReadOnlyRecommended:=False
objWB.Close
objExcel.DisplayAlerts = True
Set objRNG = Nothing
Set objWS = Nothing
Set objWB = Nothing
objExcel.Quit
Set objExcel = Nothing
Set objRS = Nothing
End Sub