Stew, thanks for the info! I have fixed my code and it works fine until it gets to
Set wksFashionAccessories = wbk.Sheets("Sheet4"
<--- 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 "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
With rstHandMade
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Handmade'", conn, adOpenKeyset, adLockOptimistic
End With
With rstFashionAccessories
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Fashion Accessories'", conn, adOpenKeyset, adLockOptimistic
End With
With rstLAContemporary
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='LA Contemporary'", conn, adOpenKeyset, adLockOptimistic
End With
With rstJewelry
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Jewelry'", conn, adOpenKeyset, adLockOptimistic
End With
With rstGeneralGift
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='General Gift'", conn, adOpenKeyset, adLockOptimistic
End With
With rstOutdoorElement
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Outdoor Elements'", conn, adOpenKeyset, adLockOptimistic
End With
With rstResort
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Sourvenir Resort'", conn, adOpenKeyset, adLockOptimistic
End With
With rstStationery
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Stationery'", conn, adOpenKeyset, adLockOptimistic
End With
With rstJustKidsStuff
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='Just Kid Stuff'", conn, adOpenKeyset, adLockOptimistic
End With
With rstWorldStyle
.Open "SELECT Company FROM tblTopPick WHERE TOP10=-1 and Category='World Style'", conn, adOpenKeyset, adLockOptimistic
End With
Set myExcel = New Excel.Application
Set wbk = myExcel.Workbooks.Add
Set wksAtHome = wbk.Sheets("Sheet1"

Set wksExTracts = wbk.Sheets("Sheet2"

Set wksHandmade = wbk.Sheets("Sheet3"

Set wksFashionAccessories = wbk.Sheets("Sheet4"
<--- Error occurs here
Set wksLAContemporary = wbk.Sheets("Sheet5"

Set wksJewelry = wbk.Sheets("Sheet6"

Set wksGeneralGift = wbk.Sheets("Sheet7"

Set wksOutdoorElement = wbk.Sheets("Sheet8"

Set wksResort = wbk.Sheets("Sheet9"

Set wksStationery = wbk.Sheets("Sheet10"

Set wksJustKidsStuff = wbk.Sheets("Sheet11"

Set wksWorldStyle = wbk.Sheets("Sheet12"
myExcel.Visible = True
With wksAtHome
.Cells(2, 2).Value = "At Home"
End With
With wksExTracts
.Cells(2, 2).Value = "Extracts"
End With
With wksHandmade
.Cells(2, 2).Value = "Handmade"
End With
With wksFashionAccessories
.Cells(2, 2).Value = "Fashion Accessories"
End With
With wksLAContemporary
.Cells(2, 2).Value = "LA Contemporary"
End With
With wksJewelry
.Cells(2, 2).Value = "Jewelry"
End With
With wksGeneralGift
.Cells(2, 2).Value = "General Gift"
End With
With wksOutdoorElement
.Cells(2, 2).Value = "Outdoor Element"
End With
With wksResort
.Cells(2, 2).Value = "Resort"
End With
With wksStationery
.Cells(2, 2).Value = "Stationery"
End With
With wksJustKidsStuff
.Cells(2, 2).Value = "Just Kids Stuff"
End With
With wksWorldStyle
.Cells(2, 2).Value = "World Style"
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("A

"

.AutoFit
wksExTracts.Columns("A

"

.AutoFit
wksHandmade.Columns("A

"

.AutoFit
wksFashionAccessories.Columns("A

"

.AutoFit
wksLAContemporary.Columns("A

"

.AutoFit
wksJewelry.Columns("A

"

.AutoFit
wksGeneralGift.Columns("A

"

.AutoFit
wksOutdoorElement.Columns("A

"

.AutoFit
wksResort.Columns("A

"

.AutoFit
wksStationery.Columns("A

"

.AutoFit
wksJustKidsStuff.Columns("A

"

.AutoFit
wksWorldStyle.Columns("A

"

.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_Test1.xls"
myExcel.Quit
Exit Sub
ErrorHandle:
MsgBox Err.Description, vbCritical, "Automation Error"
Set myExcel = Nothing
Exit Sub
End Sub Paul
paul_wilson74@hotmail.com