pancho_alvarez
asked on
Exporting Access Query to an Excel Spreadsheet
I have a query called "usp_Anomalies" that I would like to export to an Excel sheet. I have the following code that works and that I have attached as a code snippet. The only thing left is the export process. Please note that the data of the query must be exported including the COLUMN NAMES of the query.
Dim sSQL As String
Dim objXL As Object
Dim objWB As Object
Dim sFile As String
Dim sShtName As String
Dim i As Integer
'Set name of file to save to
sFile = "C:\ANOMALIES.XLS"
'Set name of new sheet
sShtName = "ANOMALIES"
'Create a new excel document
Set objXL = CreateObject("Excel.Application")
'create new workbook
Set objWB = objXL.Workbooks.Add
'Save as a new file, delete existing file if it exists
If Dir$(sFile) <> "" Then Kill sFile
objWB.SaveAs sFile
objWB.Close
objXL.Quit
'CLOSE DOWN
Set objWB = Nothing
Set objXL = Nothing
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
This is stock code from the Excel help file for the CopyFromRecordset function that sets the field names and copies all the data in 1 shot which is much faster than looping.
For iCols = 0 to rs.Fields.Count - 1
ws.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
ws.Range(ws.Cells(1, 1), ws.Cells(1, rs.Fields.Count)).Font.Bol d = True
ws.Range("A2").CopyFromRec ordset rs
Steve
For iCols = 0 to rs.Fields.Count - 1
ws.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
ws.Range(ws.Cells(1, 1), ws.Cells(1, rs.Fields.Count)).Font.Bol
ws.Range("A2").CopyFromRec
Steve
Good to know - I replaced that section in my own code. Thanks!
Well try this...
Define the name in the sheet where u want to paste the data from access to excel
Sub ImportAccess()
Dim MyAccess As Database
Dim MyTemp As DAO.Recordset
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "Importing Data From Access"
Sheets("Your Sheet Name").Select
Range("Your Range Name").Select
Selection.clearcontents
Set MyAccess = OpenDatabase("Your database path")
Set MyTemp = MyAccess.OpenRecordset("us p_Anomalie s")
'**********Importing From Access**********
Sheets("Your Sheet Name").Select
Range("Your Range Name").Select
Selection.CopyFromRecordse t MyTemp
Range("a1").Select
End Sub
Define the name in the sheet where u want to paste the data from access to excel
Sub ImportAccess()
Dim MyAccess As Database
Dim MyTemp As DAO.Recordset
Application.ScreenUpdating
Application.DisplayAlerts = False
Application.StatusBar = "Importing Data From Access"
Sheets("Your Sheet Name").Select
Range("Your Range Name").Select
Selection.clearcontents
Set MyAccess = OpenDatabase("Your database path")
Set MyTemp = MyAccess.OpenRecordset("us
'**********Importing From Access**********
Sheets("Your Sheet Name").Select
Range("Your Range Name").Select
Selection.CopyFromRecordse
Range("a1").Select
End Sub
DoCmd.OutputTo acOutputForm, "Query Name", acFormatXLS, , True
I also have a more complex code set up for another that updates, exports, formats & saves a table based on a query (converted the query contents to a table in order to avoid memo fields being cut off at 250 characters) that looks like the following:
Sub export_to_excel click()
DoCmd.SetWarnings False
DoCmd.OpenQuery "Current Table Contents-Delete query", acViewNormal, acEdit
DoCmd.Close acQuery, "Current Table Contents-Delete query"
DoCmd.OpenQuery "Update with new data to be Exported-Append query", acViewNormal, acEdit
DoCmd.Close acQuery, "Update with new data to be Exported-Append query"
DoCmd.SetWarnings True
Dim objXL As Object
Dim objWB As Object
Dim objSheet As Object
Dim rs As DAO.Recordset
Dim i As Integer
Dim lRow As Long
Dim Pth
Pth = CurrentProject.Path & "\File name.xls"
On Error Resume Next
Kill Pth
Set rs = CurrentDb.OpenRecordset("E
Set objXL = CreateObject("Excel.Applic
Set objWB = objXL.Workbooks.Add
Set objSheet = objXL.ActiveSheet
'Create Header - set to hold 5 fields (increase 0 to 4 range if there are more)
For i = 0 To 4
objSheet.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
'Fill in with data (4 columns)
lRow = 2
Do While Not rs.EOF
For i = 0 To 4
objSheet.Cells(lRow, i + 1).Value = rs.Fields(i).Value
Next i
rs.MoveNext
lRow = lRow + 1
Loop
objSheet.Range("A1:E1").Fo
objSheet.Rows("1:1").RowHe
objSheet.Columns("A:B").au
objSheet.Columns("C").Colu
objSheet.Columns("E").Colu
objSheet.Columns("D").Colu
objSheet.Columns("A:E").Wr
objSheet.Range("A2:E2000")
With objSheet.Rows("1:1").Inter
.ColorIndex = 15
.Pattern = xlSolid
End With
objSheet.Rows(2).Select
objXL.ActiveWindow.FreezeP
objWB.SaveAs Pth
rs.Close
Set rs = Nothing
objXL.Visible = True
End Sub