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