Exporting multiple recordsets into multiple Excel sheets

[pewilson]

I need to figure a way to export 12 files from my database into one excel file onto 12 different sheets. I know how to use the DoCmd.Transfer method, but I would like to use VBA to export the data and to have it start at specific cells. I know how do it for one, but not for multiple recordsets. If anyone can assist me I would greatly appreciate the help.

Thanks, Paul
paul_wilson74@hotmail.com

 

[mymou]

Hi pewilson

Have you looked at DoCmd.TransferSpreadsheet?

If you just type in the sheet name in the 'range' - it will do what you need.

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "table1", "C:/new.xls", False, "budget"

Or something like that - for a new sheet "budget".

Stew

 

[pewilson]

Sub CopyToExcel()
Dim conn As ADODB.Connection

Dim rstAtHome As ADODB.Recordset
Dim rstExTracts As ADODB.Recordset
Dim wbk As Excel.Workbook
Dim wksAtHome As Excel.Workbook
Dim wksExTracts As Excel.Worksheet

Dim StartRange1 As Excel.Range
Dim StartRange2 As Excel.Range

On Error GoTo ErrorHandle
Set conn = CurrentProject.Connection
Set rstAtHome = New ADODB.Recordset
Set rstExTracts = New ADODB.Recordset

With rstAtHome
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='At Home'", conn, adOpenKeyset, adLockOptimistic
End With

With rstExTracts
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='ExTracts'", conn, adOpenKeyset, adLockOptimistic
End With

Set myExcel = New Excel.Application
Set wbk = myExcel.Workbooks.Add

Set wksAtHome = wbk.Sheets("Sheet1&quot
Set wksExTracts = wbk.Sheets("Sheet2&quot

myExcel.Visible = True


With wksAtHome

.Cells(2, 2).Value = "At Home"
End With

With wksExTracts

.Cells(2, 2).Value = "Extracts"
End With
Set StartRange1 = wksAtHome.Cells(3, 2)
Set StartRange2 = wksExTracts.Cells(3, 2)

StartRange1.CopyFromRecordset rstAtHome
StartRange2.CopyFromRecordset rstExTracts

wksAtHome.Columns("A&quot.AutoFit
wksExTracts.Columns("A&quot.AutoFit


wbk.Close savechanges:=True, Filename:="J:\Sales ToolShed\Sales ToolShed_CGS_0702(Current Data)\Top 10 Store Wish List\Top 10 Store Wish List_Test.xls"
myExcel.Quit

Exit Sub

ErrorHandle:
MsgBox Err.Description, vbCritical, "Automation Error"
Set myExcel = Nothing
Exit Sub

End Sub

Well this is what Im actually trying to do. Im trying to create a new Excel workbooks with 2 new worksheets from 2 different SQL statements. But I am erroring on the

Set wksAtHome = wbk.Sheets(&quot;Sheet1&quot<----Error occurring here
So does anyone know what Im doing wrong?
Paul
paul_wilson74@hotmail.com

 

[mymou]

Hi pewilson

Looks like a typo to me

Dim wksAtHome As Excel.WORKBOOK - this doesn't (for obvious reasons)
Dim wksExTracts As Excel.Worksheet - this works


Just as a suggestion, I would say that you should stay away from code if (big if) applicable (easier to maintain etc).

&quot;At Home&quot; and &quot;Extracts&quot; are just field header that can be included in the query

eg
SELECT Company as [At Home]

You could then use Microsoft query in Excel to get the data into excel. Very easy, no code - but does 'split' the application. Just another approach. The export spreadsheet method cannot specify a specific range - so not useful in your case (unless you choose to start linking cell in Excel, or run a macro blah blah)

Also as a suggestion, At Home and Extracts - really should be held in a reference table - and the categories would then be represented by numbers. Just boring normalisation.

There is also a SELECT TOP 10 Company as [At Home] which might be useful to you.
This is available under the properties of a query (just right click - properties).

Think that that is it.

Stew

 

[pewilson]

Stew, thanks for the info! I have fixed my code and it works fine until it gets to
Set wksFashionAccessories = wbk.Sheets(&quot;Sheet4&quot<--- Error occurs here. I get a Subscript out of range message. Is this happening because when I create a new workbook only 3 sheets are created? So Im not sure how to get around that.
And regarding the SQL statement you mention who I should use the Top 10. Actually when the user is entering data, they save the store as a Top 10 or a Top 25 store.

Thanks for the help

Public myExcel As Excel.Application

Sub CopyToExcel()
Dim conn As ADODB.Connection

Dim rstAtHome As ADODB.Recordset
Dim rstExTracts As ADODB.Recordset
Dim rstHandMade As ADODB.Recordset
Dim rstFashionAccessories As ADODB.Recordset
Dim rstLAContemporary As ADODB.Recordset
Dim rstJewelry As ADODB.Recordset
Dim rstGeneralGift As ADODB.Recordset
Dim rstOutdoorElement As ADODB.Recordset
Dim rstResort As ADODB.Recordset
Dim rstStationery As ADODB.Recordset
Dim rstJustKidsStuff As ADODB.Recordset
Dim rstWorldStyle As ADODB.Recordset

Dim wbk As Excel.Workbook
Dim wksAtHome As Excel.Worksheet
Dim wksExTracts As Excel.Worksheet
Dim wksHandmade As Excel.Worksheet
Dim wksFashionAccessories As Excel.Worksheet
Dim wksLAContemporary As Excel.Worksheet
Dim wksJewelry As Excel.Worksheet
Dim wksGeneralGift As Excel.Worksheet
Dim wksOutdoorElement As Excel.Worksheet
Dim wksResort As Excel.Worksheet
Dim wksStationery As Excel.Worksheet
Dim wksJustKidsStuff As Excel.Worksheet
Dim wksWorldStyle As Excel.Worksheet
Dim StartRange1 As Excel.Range
Dim StartRange2 As Excel.Range
Dim StartRange3 As Excel.Range
Dim StartRange4 As Excel.Range
Dim StartRange5 As Excel.Range
Dim StartRange6 As Excel.Range
Dim StartRange7 As Excel.Range
Dim StartRange8 As Excel.Range
Dim StartRange9 As Excel.Range
Dim StartRange10 As Excel.Range
Dim StartRange11 As Excel.Range
Dim StartRange12 As Excel.Range

On Error GoTo ErrorHandle
Set conn = CurrentProject.Connection
Set rstAtHome = New ADODB.Recordset
Set rstExTracts = New ADODB.Recordset
Set rstHandMade = New ADODB.Recordset
Set rstFashionAccessories = New ADODB.Recordset
Set rstLAContemporary = New ADODB.Recordset
Set rstJewelry = New ADODB.Recordset
Set rstGeneralGift = New ADODB.Recordset
Set rstOutdoorElement = New ADODB.Recordset
Set rstResort = New ADODB.Recordset
Set rstStationery = New ADODB.Recordset
Set rstJustKidsStuff = New ADODB.Recordset
Set rstWorldStyle = New ADODB.Recordset

With rstAtHome
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='At Home'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstExTracts
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='ExTracts'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstHandMade
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Handmade'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstFashionAccessories
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Fashion Accessories'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstLAContemporary
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='LA Contemporary'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstJewelry
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Jewelry'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstGeneralGift
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='General Gift'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstOutdoorElement
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Outdoor Elements'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstResort
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Sourvenir Resort'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstStationery
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Stationery'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstJustKidsStuff
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Just Kid Stuff'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

With rstWorldStyle
.Open &quot;SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='World Style'&quot;, conn, adOpenKeyset, adLockOptimistic
End With

Set myExcel = New Excel.Application

Set wbk = myExcel.Workbooks.Add

Set wksAtHome = wbk.Sheets(&quot;Sheet1&quot
Set wksExTracts = wbk.Sheets(&quot;Sheet2&quot
Set wksHandmade = wbk.Sheets(&quot;Sheet3&quot
Set wksFashionAccessories = wbk.Sheets(&quot;Sheet4&quot<--- Error occurs here
Set wksLAContemporary = wbk.Sheets(&quot;Sheet5&quot
Set wksJewelry = wbk.Sheets(&quot;Sheet6&quot
Set wksGeneralGift = wbk.Sheets(&quot;Sheet7&quot
Set wksOutdoorElement = wbk.Sheets(&quot;Sheet8&quot
Set wksResort = wbk.Sheets(&quot;Sheet9&quot
Set wksStationery = wbk.Sheets(&quot;Sheet10&quot
Set wksJustKidsStuff = wbk.Sheets(&quot;Sheet11&quot
Set wksWorldStyle = wbk.Sheets(&quot;Sheet12&quot

myExcel.Visible = True


With wksAtHome

.Cells(2, 2).Value = &quot;At Home&quot;
End With

With wksExTracts

.Cells(2, 2).Value = &quot;Extracts&quot;
End With

With wksHandmade

.Cells(2, 2).Value = &quot;Handmade&quot;
End With

With wksFashionAccessories

.Cells(2, 2).Value = &quot;Fashion Accessories&quot;
End With

With wksLAContemporary

.Cells(2, 2).Value = &quot;LA Contemporary&quot;
End With

With wksJewelry

.Cells(2, 2).Value = &quot;Jewelry&quot;
End With

With wksGeneralGift

.Cells(2, 2).Value = &quot;General Gift&quot;
End With

With wksOutdoorElement

.Cells(2, 2).Value = &quot;Outdoor Element&quot;
End With

With wksResort

.Cells(2, 2).Value = &quot;Resort&quot;
End With

With wksStationery

.Cells(2, 2).Value = &quot;Stationery&quot;
End With

With wksJustKidsStuff

.Cells(2, 2).Value = &quot;Just Kids Stuff&quot;
End With

With wksWorldStyle

.Cells(2, 2).Value = &quot;World Style&quot;
End With

Set StartRange1 = wksAtHome.Cells(3, 2)
Set StartRange2 = wksExTracts.Cells(3, 2)
Set StartRange3 = wksHandmade.Cells(3, 2)
Set StartRange4 = wksFashionAccessories.Cells(3, 2)
Set StartRange5 = wksLAContemporary.Cells(3, 2)
Set StartRange6 = wksJewelry.Cells(3, 2)
Set StartRange7 = wksGeneralGift.Cells(3, 2)
Set StartRange8 = wksOutdoorElement.Cells(3, 2)
Set StartRange9 = wksResort.Cells(3, 2)
Set StartRange10 = wksStationery.Cells(3, 2)
Set StartRange11 = wksJustKidsStuff.Cells(3, 2)
Set StartRange12 = wksWorldStyle.Cells(3, 2)


StartRange1.CopyFromRecordset rstAtHome
StartRange2.CopyFromRecordset rstExTracts
StartRange3.CopyFromRecordset rstHandMade
StartRange4.CopyFromRecordset rstFashionAccessories
StartRange5.CopyFromRecordset rstLAContemporary
StartRange6.CopyFromRecordset rstJewelry
StartRange7.CopyFromRecordset rstGeneralGift
StartRange8.CopyFromRecordset rstOutdoorElement
StartRange9.CopyFromRecordset rstResort
StartRange10.CopyFromRecordset rstStationery
StartRange11.CopyFromRecordset rstJustKidsStuff
StartRange12.CopyFromRecordset rstWorldStyle

wksAtHome.Columns(&quot;A&quot.AutoFit
wksExTracts.Columns(&quot;A&quot.AutoFit
wksHandmade.Columns(&quot;A&quot.AutoFit
wksFashionAccessories.Columns(&quot;A&quot.AutoFit
wksLAContemporary.Columns(&quot;A&quot.AutoFit
wksJewelry.Columns(&quot;A&quot.AutoFit
wksGeneralGift.Columns(&quot;A&quot.AutoFit
wksOutdoorElement.Columns(&quot;A&quot.AutoFit
wksResort.Columns(&quot;A&quot.AutoFit
wksStationery.Columns(&quot;A&quot.AutoFit
wksJustKidsStuff.Columns(&quot;A&quot.AutoFit
wksWorldStyle.Columns(&quot;A&quot.AutoFit

wbk.Close savechanges:=True, Filename:=&quot;J:\Sales ToolShed\Sales ToolShed_CGS_0702(Current Data)\Top 10 Store Wish List\Top 10 Store Wish List_Test1.xls&quot;
myExcel.Quit

Exit Sub

ErrorHandle:
MsgBox Err.Description, vbCritical, &quot;Automation Error&quot;
Set myExcel = Nothing
Exit Sub

End Sub Paul
paul_wilson74@hotmail.com

 

[mymou]

Hi pewilson

Just add this statement to add a new worksheet:
wbk.Sheets.Add After:=Worksheets(Worksheets.Count)

This will work as you require but I would also add
wbk.Sheets(Worksheets.Count).Name = &quot;New Name of Sheet&quot;
Cause I like that kind of stuff.

You can also check if enough worksheets exists and add only if required. This may be required as the default number of sheets in new workbook is easy to change.
Application.SheetsInNewWorkbook


If you want to make your code a little more generic - change it so it loops around - creating the SQL on the fly. The code would be sorter, simplier(?) and would allow for additional categories.

Still reccommend that you use a reference table!

Stew