Export Filtered Data to Excel

[FrymanTCU]

Okay I know this is a dumb question but I have been searching the forum all morning but have not found an answer. I have a form to search the data in my database, it does this by filtering the main data table in a subform. Once the results are filtered I want to give the user the option to export the results and save the file to a location of their choice.

It seems like there are a million ways to go about this... DoCmd.OutputTo, Docmd.TransferSpreedsheet, Exporting the SQL string... I'm just not sure which way to go about tackling the problem.

Unless there is a way to select the filtered data in subform I think I will need to build a SQL query and export that. Then there is the task of saving the file to a particular location, do I open the Save As dialog box in Access or Excel?

Like I said I'm really stuck on how to tackle this one... I have pasted the code from my filter below if anyone could help I would appreciate it.

Thanks,
Rich

Private Sub Search_Click()
Const cInvalidDateError As String = "You have entered an invalid date."
Dim strWhere As String
Dim strError As String

strWhere = "1=1"

If Not IsNull(Me.cboUserName) Then
'Create Predicate
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[USER NAME] Like '*" & Me.cboUserName & "*'"
End If
If Not IsNull(Me.cboDocDescription) Then
'Add the predicate
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[DOC DESCRIPTION] Like '*" & Trim(Me.cboDocDescription) & "*'"
End If
If Nz(Me.cboAuditDecision) <> "" Then
'Add it to the predicate - exact match
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[AuditID] = " & Me.cboAuditDecision & ""
End If
If Nz(Me.BranchID) <> "" Then
'Add it to the predicate - exact match
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[OFFICE] Like'*" & Format(Me.BranchID, "0000") & "*'"
End If
If Nz(Me.AccountNum) <> "" Then
'Add it to the predicate - exact match
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[ACCOUNT BASE] = '" & Me.AccountNum & "'"
End If
' If Opened Date From
If IsDate(Me.OpenedDateFrom) Then
' Add it to the predicate - exact
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[DOC CHANGE DATE]>= " & GetDateFilter(Me.OpenedDateFrom)
ElseIf Nz(Me.OpenedDateFrom) <> "" Then
strError = cInvalidDateError
End If
' If Opened Date To
If IsDate(Me.OpenedDateTo) Then
' Add it to the predicate - exact
strWhere = strWhere & " AND " & "[AUDIT HISTORY].[DOC CHANGE DATE]<= " & GetDateFilter(Me.OpenedDateTo)
ElseIf Nz(Me.OpenedDateTo) <> "" Then
strError = cInvalidDateError
End If
If strError <> "" Then
MsgBox strError
Else
If Not Me.FormFooter.Visible Then
Me.FormFooter.Visible = True
DoCmd.MoveSize Height:=Me.WindowHeight + Me.FormFooter.Height
End If
Me.FollowUpSubForm.Form.Filter = strWhere
Me.FollowUpSubForm.Form.FilterOn = True
End If
End Sub

[CreganTur]

The following code is an example that grabs a DAO recordset and then exports the gathered recordset to Excel. You'll need to play around with it a bit to make it do what you want.

What you're going to need to do is build up your SQL string like you're already doing. Then you'll pass your SQL string into the OpenRecordset method, like this:
rst = db.OpenRecordset(strSQL)
Where strSQL is your SQL string.

Sub ExportToExcelDAO()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim xlApp As Object
Dim wkb As Object
Dim rng As Object
Dim strExcelFile As String
Dim strDB As String
Dim strTable As String
Dim count As Integer
Dim iCol As Integer
Dim rowsToReturn As Integer
Dim objSheet As Object
strDB = "C:\Acc07_ByExample\Northwind.mdb"
strTable = "Employees"
strExcelFile = "C:\Acc07_ByExample\ExcelFromAccess.xls"
'if excel file already exists delete it
If Dir(strExcelFile) <> "" Then Kill strExcelFile
Set db = OpenDatabase(strDB)
Set rst = db.OpenRecordset(strTable)
'get number of records in recordset
count = rst.RecordCount
rowsToReturn = CInt(InputBox("How many records to copy?"))
If rowsToReturn <= count Then
'set reference to Excel to make Excel visible
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
'set references to workbook and worksheet
Set wkb = xlApp.Workbooks.Add
Set objSheet = xlApp.ActiveWorkbook.Sheets(1)
objSheet.Activate

'write column names to the first worksheet row
For iCol = 0 To rst.Fields.count - 1
objSheet.Cells(1, iCol + 1).Value = rst.Fields(iCol).Name
Next
'specify cell range to recieve data
Set rng = objSheet.Cells(2, 1)

'copy specified number of records to worksheet
rng.CopyFromRecordset rst, rowsToReturn
'autofit columns to make data fit
objSheet.Columns.AutoFit

'close the workbook
wkb.SaveAs FileName:=strExcelFile
wkb.Close

'quit excel and release object variables
Set objSheet = Nothing
Set wkb = Nothing
xlApp.Quit
Set xlApp = Nothing
Else
MsgBox "Please specify a number less than " & count + 1 & "."
End If
db.Close
Set db = Nothing
End Sub

Hope this points you in the right direction.

[FrymanTCU]

Thanks Randy, if I leave the wkb.saveas portion out will it prompt me to save the file a different location?

[CreganTur]

This MSDN Article (http://msdn.microsoft.com/en-us/library/aa140112(office.10).aspx) shows you how you can utilize the SaveAs dialog box in your coding. This will allow User selection.

[FrymanTCU]

Sorry Duplicate post...

[FrymanTCU]

This works one time but when i reset the filter and attempt to run the export again it gives me a Run Time error '91' - Object Variable or With Block not set... Any ideas?

Private Sub btnReports_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim xlApp As Object, wkb As Object, rng As Object, objSheet As Object
Dim strExcelFile As String
Dim rowCount As Integer, iCol As Integer

Set db = CurrentDb

Set rst = db.OpenRecordset(mySQLfinal$)
'get number of records in recordset
rowCount = rst.RecordCount
'set reference to Excel to make Excel visible
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
'set references to workbook and worksheet
Set wkb = xlApp.Workbooks.Add
Set objSheet = xlApp.ActiveWorkbook.Sheets(1)
objSheet.Activate

'write column names to the first worksheet row
For iCol = 0 To rst.Fields.Count - 1
objSheet.cells(1, iCol + 1).Value = rst.Fields(iCol).Name
With objSheet.cells(1, iCol + 1)
.Value = rst.Fields(iCol).Name
.Select
With Selection
''ERROR OCCURS HERE????
.HorizontalAlignment = xlCenter
With Selection.Font
.FontStyle = "Bold"
.Size = 8
.ColorIndex = 2
End With
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End With
End With
Next
'specify cell range to recieve data
Set rng = objSheet.cells(2, 1)

'copy specified number of records to worksheet
rng.CopyFromRecordset rst, rowCount
'autofit columns to make data fit
objSheet.Columns.AutoFit
objSheet.cells.Select
Selection.Font.Size = 8
objSheet.cells(1, 1).Select

'close the workbook
' wkb.SaveAs FileName:=strExcelFile
' wkb.Close
'quit excel and release object variables
Set objSheet = Nothing
Set wkb = Nothing
' xlApp.Quit
Set xlApp = Nothing
db.Close
Set db = Nothing

[FrymanTCU]

So I've isolated the problem to the .select command. I think access is referencing the wrong file becuase it added the formating to a different cell that was selected in a different workbook... Any ideas?

[FrymanTCU]

So I've been playing with this script and have still havent solved the problem.. It my objSheet Object is referencing Book 1 when I'm trying to update Book 2. I realize I'm not using the strExcelFile string in the code, so does anyone know where to add that so objSheet references the newest excel file I have created? Thanks

[CreganTur]

The code I provided is built to only export recordsets to new worksheets, not populate existing worksheets/workbooks.

If you're wanting to export the recordset to an existing workbook then there are a few more hurdles.

[FrymanTCU]

No I want to create new files but I am trying to add some formatting to that file. The first time I run the export everything works fine but if I run the export a second time without closing the database completely the formating does not function properly.

[CreganTur]

It could have something to do with the fact that your code doesn't quit the excel application. If you're leaving it open that could be causing the problem. Also check your Task Manager at the end of a run and see if Excel is showing as an active process.

[FrymanTCU]

No I saved the file and quit excel and still recieved the error when I tried to format the cell... The cursor is in the right location but it won't allow me to apply the formating. I went back to your original script and it was able to export multiple times, so it has to be with the formating. I'm going to see if the excel form can help out on this. Thanks for your help Randy.