Sub ExportToExcel()
' uses late binding for Excel
Dim rs AS DAO.Recordset
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Dim Counter As Long
Dim ColNumber As Long
Const SaveToPath As String = "c:\Results\Report_"
Const SQL As String = "SELECT * FROM [SomeTable]"
Const ColumnToDelete As String = "DeleteMe"
Set rs = CurrentDb.OpenRecordset(SQL)
' instantiate Excel object
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets(1)
With xlWs
' write recordset headings
For Counter = 0 To rs.Fields.Count - 1
.Cells(1, Counter + 1) = rs.Fields(Counter).Name
Next
.Cells(2, 1).CopyFromRecordset rs
If xlApp.CountIf(.Range("1:1"), ColumnToDelete) > 0 Then
ColNumber = xlApp.Match(ColumnToDelete, .Range("1:1"), 0)
.Cells(1, ColNumber).EntireColumn.Delete
End If
End With
' Excel 2007/2010 requires the file format to be specified, so check
' for application version. see for more info:
' http://www.dailydoseofexcel.com/archives/2006/10/29/saveas-in-excel-2007/
If Val(xlApp.Version) < 12 Then
xlWb.SaveAs SaveToPath & Format(Now, "yyyymmdd") & ".xls"
Else
' to use XLSX format:
xlWb.SaveAs SaveToPath & Format(Now, "yyyymmdd") & ".xlsx", 51
' or to use XLSM format:
'xlWb.SaveAs SaveToPath & Format(Now, "yyyymmdd") & ".xlsm", 52
' or to use XLSB format:
'xlWb.SaveAs SaveToPath & Format(Now, "yyyymmdd") & ".xlsb", 50
' or to use good old XLS format:
'xlWb.SaveAs SaveToPath & Format(Now, "yyyymmdd") & ".xls", 56
End If
xlWb.Close False
xlApp.DisplayAlerts = True
Set xlWs = Nothing
Set xlWb = Nothing
xlApp.Quit
Set xlApp = Nothing
rs.Close
Set rs = Nothing
MsgBox "Done"
End Sub
|