Exporting filtered tables into dif excel worksheets (1 Viewer)

Public Function SendTQ2ExcelSheets(strTQSQL As String, strSheetName As String, strFileName As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to name it to
' strFileName is the file path and name of the existing workbook to open (including extension)
 
    Dim rst As DAO.Recordset
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Dim i As Integer
    Dim blnSheetExists As Boolean
    Dim blnFileExists As Boolean
 
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
 
    On Error GoTo err_handler
 
    Set rst = CurrentDb.OpenRecordset(strTQSQL)
 
    If IsNothing(objXL) Then
       Set objXL = CreateObject("Excel.Application")
    End If
 
    If Dir(strFileName) = vbNullString Then
        Set xlWBk = objXL.Workbooks.Add
    Else
        Set xlWBk = objXL.Workbooks.Open(strFileName)
        blnFileExists = True
    End If
 
' this is here for debugging only.  comment it out for production so Excel doesn't show.
    objXL.Visible = True
 
    With xlWBk
        i = 1
        Do Until i = .Worksheets.Count + 1
            If .Worksheets(i).Name = strSheetName Then
                blnSheetExists = True
            End If
            i = i + 1
        Loop
 
        If Len(strSheetName) > 31 Then
            strSheetName = Left(strSheetName, 31)
        End If
 
        If blnSheetExists Then
                    Set xlWSh = .Worksheets(strSheetName)
        Else
            Set xlWSh = .Worksheets.Add
            xlWSh.Name = strSheetName
        End If
 
    End With
 
    xlWSh.Range("A1").Select
 
    For Each fld In rst.Fields
        objXL.ActiveCell = fld.Name
        objXL.ActiveCell.Offset(0, 1).Select
    Next
 
    rst.MoveFirst
 
    xlWSh.Range("A2").CopyFromRecordset rst
    xlWSh.Range("1:1").Select
 
    ' selects all of the cells
    objXL.ActiveSheet.Cells.Select
 
    ' does the "autofit" for all columns
    objXL.ActiveSheet.Cells.EntireColumn.AutoFit
 
    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select
 
    If blnFileExists Then
        xlWBk.Save
    Else
        xlWBk.SaveAs strFileName
    End If
 
    xlWBk.Close
    rst.Close
    Set rst = Nothing
 
ExitThis:
    Exit Function
 
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume ExitThis
    Resume
 
End Function

Private objXL As Object

Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strSQL As String
 
Set db = CurrentDb
 
strSQL = "Select * FROM YourTableNameWhichListsBranches " & _
            "ORDER BY Branch"
 
Set rst = db.OpenRecordset(strSQL)
 
Do Until rst.EOF
    For Each tdf In db.TableDefs
       If Instr(1, tdf.Name, "SEND") > 0 Then
          strSQL = "SELECT *  FROM [" & tdf.Name & "] WHERE BRANCH = " & rst!Branch
          SendTQ2ExcelSheets strSQL, Replace(tdf.Name, "_SEND", vbNullstring), "C:\SomeFolder\" & rst!Branch & ".xls"
       End If
    Next
    rst.MoveNext
Loop
 
rst.Close
Set tdf = Nothing
Set rst = Nothing
Set db = Nothing

Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strSQL As String
[COLOR=red]Dim strField As String[/COLOR]
[COLOR=red]Dim fld As DAO.Field
[/COLOR] 
Set db = CurrentDb
 
strSQL = "Select * FROM YourTableNameWhichListsBranches " & _
            "ORDER BY Branch"
 
Set rst = db.OpenRecordset(strSQL)
 
Do Until rst.EOF
    For Each tdf In db.TableDefs
[COLOR=red]       For Each fld In tdf.Fields[/COLOR]
[COLOR=red]          If Inst(1, fld.Name, "BRANCH") > 0 Then[/COLOR]
[COLOR=red]             strField = fld.Name[/COLOR]
[COLOR=red]             Exit For[/COLOR]
[COLOR=red]          End If[/COLOR]
[COLOR=red]       Next[/COLOR]
       If Instr(1, tdf.Name, "SEND") > 0 Then
          strSQL = "SELECT *  FROM [" & tdf.Name & "] WHERE [" & strField & "] = " & rst!Branch
          SendTQ2ExcelSheets strSQL, Replace(tdf.Name, "_SEND", vbNullstring), "C:\SomeFolder\" & rst!Branch & ".xls"
       End If
    Next
    rst.MoveNext
Loop
 
rst.Close
Set tdf = Nothing
Set rst = Nothing
Set db = Nothing

strSQL = "Select [COLOR=red]DISTINCT BRANCH[/COLOR] FROM YourTableNameWhichListsBranches " & _
            "ORDER BY Branch"