Is it possible?

[TooManyReports]

I want to create a macro that will export a single query to excel, that can create multiple workbooks from a list. It is not realistic to create individual queries for each item (100+ items and changes often) and need each item in a list in a different worksheet (preferably in the same workbook). I don't really care if each worksheet is not labeled. The list will be in one query and the primary information in another.

Example

Area List: 1,2,3,4,5,6,etc


Information table: Area, Store, City, State, Zip

Output for each worksheet:
Area 1 Store 2 City New Haven State VT
Area 1 Store 3 City Johnassaburg State VT


Next worksheet:
Area 2 Store 10 City Fort Worth State TX
Area 3 Store 12 City Dallas State TX


Any ideas on how to approach this would greatly appreciated!

 

[boblarson]

No problem. First, copy this code to a standard module (not form, report or class module, but standard module) and name the module basExports.

[FONT=times new roman] 
Public Function SendTQ2ExcelNameNewSheet(strTQName As String, strSheetName As String, strWorkbookPathAndName 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 your sheet to
    
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As Field
    Dim strPath As String
    Dim blnCreatedWkBk As Boolean
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler


    Set rst = CurrentDb.OpenRecordset(strTQName)
    Set ApXL = CreateObject("Excel.Application")
 
' either creates a new workbook if the first time and it doesn't exist
' or it opens the one if it does while iterating through.
If Dir(strWorkbookPathAndName) = "" Then
    Set xlWBk = ApXL.Workbooks.Add
    blnCreatedWkBk = True
Else
    Set xlWBk = ApXL.Workbooks.Open(strWorkbookPathAndName)
    blnCreatedWkBk = False
End If

    ApXL.Visible = True
    
    Set xlWSh = xlWBk.Worksheets.Add
    xlWsh.Name = strSheetName   
 
    xlWSh.Range("A1").Select
 
    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next
    rst.MoveFirst
    xlWSh.Range("A2").CopyFromRecordset rst
    xlWSh.Range("1:1").Select

    ' selects all of the cells
    ApXL.ActiveSheet.Cells.Select

    ' does the "autofit" for all columns
    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit

    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select
 
' saves 
If blnCreatedWkBk Then
   xlWBk.SaveAs strWorkbookPathAndName
Else
   xlWBk.Save
End If
   xlWBk.Close
xlApp.Quit
 
    rst.Close
    Set rst = Nothing
   Set xlApp = Nothing
    Exit Function

err_handler:
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function
End Function

And then you can use code like this to iterate through

    Dim strSQL As String
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim rstAreas As DAO.Recordset

    Set rstAreas = CurrentDb.OpenRecordset("Select Area From AreasTableNameHere")

    Set db = CurrentDb

    For Each qdf In db.QueryDefs
        If qdf.Name = "MyTempQDF" Then
            db.QueryDefs.Delete (qdf.Name)
        End If
    Next
 

    Do Until rstAreas.EOF
 
        strSQL = "SELECT Area, Store, City, State, Zip"
        strSQL = strSQL & " FROM [Information table]"
        strSQL = strSQL & " WHERE Area =" & rst!Area

        Set qdf = CurrentDb.CreateQueryDef("MyTempQDF", strSQL)
        qdf.Close
        SendTQ2ExcelNameNewSheet MyTempQDF, "Area " & rst!Area, "C:\Test\MyAreasBook.xls"
 
 
        rst.MoveNext
 
    Loop
    rst.Close
    Set rst = Nothing
    Set qdf = Nothing

[/FONT]

 

[TooManyReports]

Thanks a lot, Bob

I think this is going to really help. One Problem - I keep getting a Compile error: ByRef Arguement type mismatch on the enlarged name:

SendTQ2ExcelNameNewSheet MyTempQDF, "Area " & rst!Area, "C:\KML\Regions.xlsx"

 

[TooManyReports]

Ok, I fixed that last error, using SendTQ2ExcelNameNewSheet (MyTempQDF, "Region " & rst!Region, "C:\KML\Regions.xlsx"). Now it is giving me
expected: =

 

[JANR]

SendTQ2ExcelNameNewSheet (MyTempQDF, "Region " & rst!Region, "C:\KML\Regions.xlsx")

Why did you put in those perens? If you look at Bob's code it isen't there, but you can use them but you have to use the "call" keyword.

Call SendTQ2ExcelNameNewSheet (.....)

or lose those perens and simply go

SendTQ2ExcelNameNewSheet MyTempQDF, "Region " & rst!Region, "C:\KML\Regions.xlsx"

JR

 

[TooManyReports]

I tried that. Does not work. It give me an error of : ByRef Arguement type mismatch
Call SendTQ2ExcelNameNewSheet (MyTempQDF, "Region " & rst!Region, "C:\KML\Regions.xlsx")



and without the () it give a syntax error.

I don't know if it makes a difference but I am using Access 2007.

 

[TooManyReports]

Here is my current code:

Private Sub Command0_Click()
Dim strSQL As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rstAreas As DAO.Recordset

Set rstAreas = CurrentDb.OpenRecordset("Select Region From STORE INFO")

Set db = CurrentDb

For Each qdf In db.QueryDefs
If qdf.Name = "MyTempQDF" Then
db.QueryDefs.Delete (qdf.Name)
End If
Next


Do Until rstAreas.EOF

strSQL = "SELECT Region, Store, Latitude,Longitude"
strSQL = strSQL & " FROM [STORE INFO]"
strSQL = strSQL & " WHERE Region =" & rst!Region

Set qdf = CurrentDb.CreateQueryDef("MyTempQDF", strSQL)
qdf.Close
Call SendTQ2ExcelNameNewSheet(MyTempQDF, "Region " & rst!Region, "C:\KML\Regions.xlsx")


rst.MoveNext

Loop
rst.Close
Set rst = Nothing
Set qdf = Nothing

End Sub

 

[TooManyReports]

Here is my almost working code. Now I am getting: class does not supports automation or does not support expected interface. I does open an excel sheet now, but it only has 1 tab and only has headers.

Private Sub Command0_Click()
Dim strSQL As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rstAreas As DAO.Recordset

Set rstAreas = CurrentDb.OpenRecordset("Select Region From STORE_INFO")

Set db = CurrentDb

For Each qdf In db.QueryDefs
If qdf.Name = "MyTempQDF" Then
db.QueryDefs.Delete (qdf.Name)
End If
Next


Do Until rstAreas.EOF

strSQL = "SELECT Region, Store, Latitude,Longitude"
strSQL = strSQL & " FROM STORE_INFO"
strSQL = strSQL & " WHERE Region =" & rstAreas![Region]

Set qdf = CurrentDb.CreateQueryDef("MyTempQDF", strSQL)
qdf.Close
Call SendTQ2ExcelNameNewSheet("MyTempQDF", "Region " & rstAreas![Region], "C:\KML\Regions.xlsx")


rstAreas.MoveNext

Loop
rst.Close
Set rstAreas = Nothing
Set qdf = Nothing

End Sub

 

[boblarson]

I believe you need the red line added:

Set qdf = CurrentDb.CreateQueryDef("MyTempQDF", strSQL)
[COLOR=red][B]CurrentDb.QueryDefs.Append("MyTempQDF")[/B][/COLOR]
qdf.Close

And then at the end you'll need:

CurrentDb.QueryDefs.Delete("MyTempQDF")

 

[TooManyReports]

The Automation error was due to DAO360.dll not being registered.

Regsvr32.exe "C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll"

Now the problem is that it tries to create a new workbook every time and it repeats its information - recreate Region 9 4 or 5 times then moves to Region 17 a few times then goes to Region 14 a few times.

I just need it to create worksheets to that excel workbook Regions.xlsx

 

[TooManyReports]

Thanks, Bob for the Code again. I am now having one last problem. I get a '424' error every time it run. I can hit OK to the error and it creates all the worksheets without a problem, other than the error popping up.
If you look at the part marked in red, that was the solution to my problem. Since Region repeats in the table more than a few times, I had to use a distinct command. I did not have to use the append command, because it was creating the query properly.

Private Sub Command0_Click()
Dim strSQL As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rstAreas As DAO.Recordset

Set rstAreas = CurrentDb.OpenRecordset("Select distinct Region From STORE_INFO")

Set db = CurrentDb

For Each qdf In db.QueryDefs
If qdf.Name = "MyTempQDF" Then
db.QueryDefs.Delete (qdf.Name)
End If
Next


Do Until rstAreas.EOF

strSQL = "SELECT Region, Store, Latitude,Longitude"
strSQL = strSQL & " FROM STORE_INFO"
strSQL = strSQL & " WHERE Region =" & rstAreas![Region]

Set qdf = CurrentDb.CreateQueryDef("MyTempQDF", strSQL)
qdf.Close
Call SendTQ2ExcelNameNewSheet("MyTempQDF", "Region " & rstAreas![Region], "C:\KML\Regions.xlsx")
CurrentDb.QueryDefs.Delete ("MyTempQDF")
rstAreas.MoveNext

Loop
rstAreas.Close
Set rstAreas = Nothing
Set qdf = Nothing
CurrentDb.QueryDefs.Delete ("MyTempQDF")

End Sub

 

[TooManyReports]

Well, I found my error. It was in the Excel export module.

xlApp.Quit

rst.Close
Set rst = Nothing
Set xlApp = Nothing
Exit Function

Those 2 needed to say ApXL instead.