|
Question : Export data from Access to multiple Excel files using a filtered string from a drop down list on a form
|
|
Using Access 2007 in the Access 2003 format Export to Excel 2003 format with Excel 2007 installed
I have a form with a drop down field that is to be used as a filter. What I want to do is be able to select a Director's name from the drop down list, and then click a command button that exports the information to Excel. Capricon1 already created the code to export the data to multiple Excel files dependent on the Directors' names; the module is named "mod_WSAManagementVerified_ExportToMultipleExcelFiles", and the code is located at the very bottom of http://www.experts-exchange.com/Microsoft/Development/MS_Access/Q_22693236.html
Now, I want to call the module mentioned above when the cmd button is clicked, and pass the string to the code; however, I'm guessing that the code will have to be rewritten to work like this, so I'll probably have to create a new module or something. If the drop down box is left blank (not selected) then I would like it to run the module above as it currently is; i.e. export all of the data parsed by the Directors' names into separate Excel files.
Thanks in advance for your help, Jon
Here is the code I am currently using for the filter and for the cmd button, but it currently doesn't work; and the code Capricon1 created is located at the link above :
Option Compare Database
Option Explicit
Dim strFilter As String
Private Sub cmdExport_click()
Dim rs As DAO.Recordset, sql1, ssql, db As DAO.Database, qd As DAO.QueryDef
Dim sWhere As String
sWhere = ""
Set db = DBEngine.Workspaces(0).Databases(0)
Set qd = db.QueryDefs("qry_DIMaster")
If InStr(qd.sql, "Where") > 0 Then
sql1 = Left(qd.sql, InStr(qd.sql, "Where") - 1)
sWhere = Mid(qd.sql, InStr(qd.sql, "Where"))
sWhere = Left(sWhere, InStr(sWhere, ";") - 1)
Else
sql1 = Replace(qd.sql, ";", "")
End If
' Accounts for Null values returned by strFilter
If Len(strFilter) > 0 Then
If Len(sWhere) > 0 Then
sWhere = sWhere & " And " & strFilter
ssql = sql1 & " " & sWhere
Else
ssql = sql1 & " Where " & strFilter
End If
Else
ssql = Replace(qd.sql, ";", "")
End If
Set rs = CurrentDb.OpenRecordset(ssql)
Dim xlObj As Object, xlFile As String
Dim Sheet As Object
xlFile = "C:\MyExcelFile.xls"
Set xlObj = CreateObject("Excel.Application")
xlObj.Workbooks.Add
Set Sheet = xlObj.activeworkbook.Sheets(1)
'This copies the headers
Dim iRow, iCol
iRow = 1
For iCol = 0 To rs.Fields.Count - 1
Sheet.cells(iRow, iCol + 1).Value = rs.Fields(iCol).Name
Next
'This copies just the data
Sheet.Range("A2").CopyFromRecordset rs
xlObj.Visible = True
'xlObj.activeworkbook.SaveAs xlFile - Un-comment if you want to automatically save the file
Set Sheet = Nothing
xlObj.Quit
Set xlObj = Nothing
rs.Close
Set rs = Nothing
End Sub
Private Sub Director_AfterUpdate()
strFilter = ""
If Me.Director <> "" And Not IsNull(Me.Director) Then
If strFilter = "" Then
strFilter = "[Director]= " & Chr(34) & Me.Director & Chr(34) & ""
Else
strFilter = strFilter & " and [Director]= " & Chr(34) & Me.Director & Chr(34) & ""
End If
End If
End Sub
|
|
|
Answer : Export data from Access to multiple Excel files using a filtered string from a drop down list on a form
|
|
jon,
try this
Option Explicit
Dim strFilter As String
Private Sub Director_AfterUpdate()
strFilter = ""
If Me.Director <> "" And Not IsNull(Me.Director) Then
If strFilter = "" Then
strFilter = "[Director]= " & Chr(34) & Me.Director & Chr(34) & ""
Else
strFilter = strFilter & " and [Director]= " & Chr(34) & Me.Director & Chr(34) & ""
End If
End If
End Sub
Private Sub cmdExport_click()
If IsNull(Me.Director) Then
exp2XL2
Else
exp2XL
End If
End Sub
Sub exp2XL()
Dim rs As DAO.Recordset, sql1, ssql, db As DAO.Database, qd As DAO.QueryDef
Set db = DBEngine.Workspaces(0).Databases(0)
Set qd = db.QueryDefs("qry_WSAManagementVerified_Export")
sql1 = Replace(qd.SQL, ";", "")
' Accounts for Null values returned by strFilter
If Len(strFilter) > 0 Then
ssql = sql1 & " where " & strFilter
Else
ssql = sql1
End If
Set rs = CurrentDb.OpenRecordset(ssql)
Dim xlObj As Object, xlFile As String
Dim Sheet As Object
xlFile = "C:\MyExcelFile.xls"
Set xlObj = CreateObject("Excel.Application")
xlObj.Workbooks.Add
Set Sheet = xlObj.activeworkbook.workSheets(1)
Sheet.Name = Me.Director
'This copies the headers
Dim iRow, iCol
iRow = 1
For iCol = 0 To rs.Fields.Count - 1
Sheet.cells(iRow, iCol + 1).Value = rs.Fields(iCol).Name
Next
'This copies just the data
Sheet.Range("A2").CopyFromRecordset rs
xlObj.Visible = True
'xlObj.activeworkbook.SaveAs xlFile - Un-comment if you want to automatically save the file
Set Sheet = Nothing
xlObj.Quit
Set xlObj = Nothing
End Sub
Sub exp2XL2()
Dim rs As DAO.Recordset, rsDir As DAO.Recordset
Dim ssql As String, iCol
Dim xlObj As Object
Dim Sheet As Object
Set rsDir = CurrentDb.OpenRecordset("select distinct LastName from qry_WSAManagementVerified_Export")
If rsDir.EOF Then Exit Sub
rsDir.MoveFirst
Do Until rsDir.EOF
Set xlObj = CreateObject("Excel.Application")
xlObj.Workbooks.Add
ssql = "SELECT qry_WSAManagementVerified_Export.EPCFunctionID, qry_WSAManagementVerified_Export.EPCFunction,"
ssql = ssql & " qry_WSAManagementVerified_Export.DirectorBems, qry_WSAManagementVerified_Export.Director,"
ssql = ssql & " qry_WSAManagementVerified_Export.WGManagerBems, qry_WSAManagementVerified_Export.WGManager,"
ssql = ssql & " qry_WSAManagementVerified_Export.WGBudgetNum, qry_WSAManagementVerified_Export.NumberOfDirectReports,"
ssql = ssql & " qry_WSAManagementVerified_Export.NumberOfWorkgroups, qry_WSAManagementVerified_Export.WGVerified,"
ssql = ssql & " qry_WSAManagementVerified_Export.WGWSARequired, qry_WSAManagementVerified_Export.WSAFunctionRequired,"
ssql = ssql & " qry_WSAManagementVerified_Export.WGWSACompletions, qry_WSAManagementVerified_Export.WGWSARemaining,"
ssql = ssql & " qry_WSAManagementVerified_Export.WGWSARequirement, qry_WSAManagementVerified_Export.WGWSAStatus,"
ssql = ssql & " qry_WSAManagementVerified_Export.WGNotes, qry_WSAManagementVerified_Export.Function_Data,"
ssql = ssql & " qry_WSAManagementVerified_Export.SubFunction_Data, qry_WSAManagementVerified_Export.Department,"
ssql = ssql & " qry_WSAManagementVerified_Export.OrgStructureCode, qry_WSAManagementVerified_Export.WSAFunctionFocalBems,"
ssql = ssql & " qry_WSAManagementVerified_Export.WSAFunctionFocal, qry_WSAManagementVerified_Export.WSAFunctionFocalType,"
ssql = ssql & " qry_WSAManagementVerified_Export.WSACompletions_Data, qry_WSAManagementVerified_Export.WSACompletions_Override,"
ssql = ssql & " qry_WSAManagementVerified_Export.DirectorBems_Override, qry_WSAManagementVerified_Export.Director_Override,"
ssql = ssql & " qry_WSAManagementVerified_Export.DirectorBems_Data, qry_WSAManagementVerified_Export.Director_Data "
ssql = ssql & " FROM qry_WSAManagementVerified_Export"
ssql = ssql & " Where qry_WSAManagementVerified_Export.LastName='" & rsDir("LastName") & "'"
Set rs = CurrentDb.OpenRecordset(ssql, dbOpenDynaset)
Set Sheet = xlObj.activeworkbook.Sheets("sheet1")
'rename the sheet, you can use any of the recordset field
Sheet.Name = rsDir("LastName")
'copy the headers
For iCol = 0 To rs.Fields.Count - 1
Sheet.cells(1, iCol + 1).Value = rs.Fields(iCol).Name
Next
Sheet.Range("A2").CopyFromRecordset rs 'copy the data
xlObj.activeworkbook.SaveAs "C:\Documents and Settings\ss974c\Desktop\" & rsDir("lastName") & "_" & "WSAVerification.xls", FileFormat:=-4143
Set Sheet = Nothing
xlObj.Quit
Set xlObj = Nothing
rsDir.MoveNext
Loop
rsDir.Close
rs.Close
Set rsDir = Nothing
Set rs = Nothing
End Sub
|
|
|
|
|
