Looping through Query to create multiple sheets in excel- Just need the loop

[Matt Pierringer]

I figured out where I should start the loop in order to keep the excel
work open and still be able to add more sheets, but I can't figure out
how to add code to For Next loop to go through a query
"qryManufacturer" and take each one and put them into the string
(strManuf)
I always get to this point and I can't figure out how to loop through
a recordset. I have put the string in the query at the bottom.

Public Sub CopyRs2SheetHacked(strSql As String, strWorkBook As String,
_
Optional strWorkSheet As String, Optional strRange As
String)
'Uses the Excel CopyFromRecordset method
'strSql: Sql Select string
'strWorkBook: Full path and name to target wb, will create
if doesn 't exist
'strWorkSheet: Name of target worksheet, will create if
doesn't exist
'strRange: Upper left cell for data, defaults to A1

On Error GoTo ProcError

DoCmd.Hourglass True

Dim objXLApp As Object 'Excel.Application
Dim objXLWb As Object 'Excel.Workbook
Dim objXLSheet As Object 'Excel.Worksheet
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim i As Integer
Dim lvlColumn As Integer

'set rs from sql, table or query
Set rs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset)
'dbOpenSnapshot

'start Excel
Set objXLApp = New Excel.Application

'open workbook, error routine will
'create it if doesn't exist
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)

'select a worksheet, if sheet doesn't exist
'the error routine will add it
'ME: Try to get Worksheet names, to loop through
qryManufacturers
'If strWorkSheet = "" Then
' strWorkSheet = "Sheet1"
'End If

'If Range is missing default to A1
If strRange = "" Then
strRange = "A2"
End If

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Start Loop
Here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)

'ME: add column headers from sql query
For lvlColumn = 0 To rs.Fields.Count - 1
objXLSheet.Cells(1, lvlColumn + 1).Value = _
rs.Fields(lvlColumn).Name
Next

'bold header row
objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Font.Bold = True
'put border around header row
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1,
rs.Fields.Count)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'insert recordset into Excel Worksheet using
CopyFromRecordset method
objXLSheet.Range(strRange).CopyFromRecordset rs
objXLSheet.Columns.AutoFit



Set objXLSheet = Nothing

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!END LOOP
HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Save wb
objXLWb.Save
objXLWb.Close

'close up other rs objects
rs.Close
Set rs = Nothing
Set objXLWb = Nothing

'quit Excel
objXLApp.Quit
Set objXLApp = Nothing

DoCmd.Hourglass False
Exit Sub

ProcError:

Select Case Err
Case 9 'Worksheet doesn't exist
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet

Resume Next

Case 1004 'Workbook doesn't exist, make it
objXLApp.Workbooks.Add
Set objXLWb = objXLApp.ActiveWorkbook
objXLWb.SaveAs strWorkBook

Resume Next

Case Else
DoCmd.Hourglass False
MsgBox Err.Number & " " & Err.Description
Stop
Resume 0
End Select

End Sub





BTW: my code to execute this w/ query sql is: CopyRs2SheetHacked
"SELECT tblProducts.Catalog, tblProducts.MaterialNumber,
tblProducts.Manufacturer, tblProducts.GMR, tblProducts.Category,
tblProducts.Description, tblProducts.[Sub-Category],
tblProducts.SortOrder, tblProducts.AddedNote, tblProducts.Required,
tblProducts.NoList, tblProducts.Hyper_Link, tblProducts.ProductID,
tblProducts.Deleted, tblProducts.Cost From tblProducts WHERE
(((tblProducts.Manufacturer) Is Not Null And
(tblProducts.Manufacturer) Like " & strManuf & ") AND
((tblProducts.Deleted)=False));", CurrentProject.Path & "\E-
Catalog.xls", strManuf, "A2"

I am sure I forgot to mention something, but I really appreciate your
help!
Thanks,
Matt Pierringer

 

[Matt Pierringer]

I figured out where I should start the loop in order to keep theexcel
work open and still be able to add more sheets, but I can't figure out
how to add code to For Next loop to go through a query
"qryManufacturer" and take each one and put them into the string
(strManuf)
I always get to this point and I can't figure out how to loop through
a recordset. I have put the string in the query at the bottom.

Public Sub CopyRs2SheetHacked(strSql As String, strWorkBook As String,
_
Optional strWorkSheet As String, Optional strRange As
String)
'Uses theExcelCopyFromRecordset method
'strSql: Sql Select string
'strWorkBook: Full path and name to target wb, will create
if doesn 't exist
'strWorkSheet: Name of target worksheet, will create if
doesn't exist
'strRange: Upper left cell for data, defaults to A1

On Error GoTo ProcError

DoCmd.Hourglass True

Dim objXLApp As Object 'Excel.Application
Dim objXLWb As Object 'Excel.Workbook
Dim objXLSheet As Object 'Excel.Worksheet
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim i As Integer
Dim lvlColumn As Integer

'set rs from sql, table or query
Set rs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset)
'dbOpenSnapshot

'startExcel
Set objXLApp = NewExcel.Application

'open workbook, error routine will
'create it if doesn't exist
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)

'select a worksheet, ifsheetdoesn't exist
'the error routine will add it
'ME: Try to get Worksheet names, to loop through
qryManufacturers
'If strWorkSheet = "" Then
' strWorkSheet = "Sheet1"
'End If

'If Range is missing default to A1
If strRange = "" Then
strRange = "A2"
End If

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Start Loop
Here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)

'ME: add column headers from sql query
For lvlColumn = 0 To rs.Fields.Count - 1
objXLSheet.Cells(1, lvlColumn + 1).Value = _
rs.Fields(lvlColumn).Name
Next

'bold header row
objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Font.Bold = True
'put border around header row
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1,
rs.Fields.Count)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'insert recordset intoExcelWorksheet using
CopyFromRecordset method
objXLSheet.Range(strRange).CopyFromRecordset rs
objXLSheet.Columns.AutoFit

Set objXLSheet = Nothing

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!END LOOP
HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!
'Save wb
objXLWb.Save
objXLWb.Close

'close up other rs objects
rs.Close
Set rs = Nothing
Set objXLWb = Nothing

'quitExcel
objXLApp.Quit
Set objXLApp = Nothing

DoCmd.Hourglass False
Exit Sub

ProcError:

Select Case Err
Case 9 'Worksheet doesn't exist
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet

Resume Next

Case 1004 'Workbook doesn't exist, make it
objXLApp.Workbooks.Add
Set objXLWb = objXLApp.ActiveWorkbook
objXLWb.SaveAs strWorkBook

Resume Next

Case Else
DoCmd.Hourglass False
MsgBox Err.Number & " " & Err.Description
Stop
Resume 0
End Select

End Sub

BTW: my code to execute this w/ query sql is: CopyRs2SheetHacked
"SELECT tblProducts.Catalog, tblProducts.MaterialNumber,
tblProducts.Manufacturer, tblProducts.GMR, tblProducts.Category,
tblProducts.Description, tblProducts.[Sub-Category],
tblProducts.SortOrder, tblProducts.AddedNote, tblProducts.Required,
tblProducts.NoList, tblProducts.Hyper_Link, tblProducts.ProductID,
tblProducts.Deleted, tblProducts.Cost From tblProducts WHERE
(((tblProducts.Manufacturer) Is Not Null And
(tblProducts.Manufacturer) Like " & strManuf & ") AND
((tblProducts.Deleted)=False));", CurrentProject.Path & "\E-
Catalog.xls", strManuf, "A2"

I am sure I forgot to mention something, but I really appreciate your
help!
Thanks,
Matt Pierringer

I didn't make my situation as clear as I could have. What I have
right now is I am able to make a workbook from excel populate a
dynamic sheet in excel. The problem I have is I have a query list of
manufacturers that I want to run through and make a new sheet for each
of them(Currently I only have one). I inserted the string in the spot
where it needs to go to get a new list from the manufactuer, but I
don't know how to loop through the list.

strManuf = should be an array of manufacturer names, probably up to 15
or so.

I appreciate anyones suggestions for how to go about doing this,

Thanks,
Matt

 

[Matt Pierringer]

I figured out where I should start the loop in order to keep theexcel
work open and still be able to add more sheets, but I can't figure out
how to add code to For Next loop to go through a query
"qryManufacturer" and take each one and put them into the string
(strManuf)
I always get to this point and I can't figure out how to loop through
a recordset. I have put the string in the query at the bottom.

Public Sub CopyRs2SheetHacked(strSql As String, strWorkBook As String,
_
Optional strWorkSheet As String, Optional strRange As
String)
'Uses theExcelCopyFromRecordset method
'strSql: Sql Select string
'strWorkBook: Full path and name to target wb, will create
if doesn 't exist
'strWorkSheet: Name of target worksheet, will create if
doesn't exist
'strRange: Upper left cell for data, defaults to A1

On Error GoTo ProcError

DoCmd.Hourglass True

Dim objXLApp As Object 'Excel.Application
Dim objXLWb As Object 'Excel.Workbook
Dim objXLSheet As Object 'Excel.Worksheet
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim i As Integer
Dim lvlColumn As Integer

'set rs from sql, table or query
Set rs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset)
'dbOpenSnapshot

'startExcel
Set objXLApp = NewExcel.Application

'open workbook, error routine will
'create it if doesn't exist
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)

'select a worksheet, ifsheetdoesn't exist
'the error routine will add it
'ME: Try to get Worksheet names, to loop through
qryManufacturers
'If strWorkSheet = "" Then
' strWorkSheet = "Sheet1"
'End If

'If Range is missing default to A1
If strRange = "" Then
strRange = "A2"
End If

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Start Loop
Here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)

'ME: add column headers from sql query
For lvlColumn = 0 To rs.Fields.Count - 1
objXLSheet.Cells(1, lvlColumn + 1).Value = _
rs.Fields(lvlColumn).Name
Next

'bold header row
objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Font.Bold = True
'put border around header row
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1,
rs.Fields.Count)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'insert recordset intoExcelWorksheet using
CopyFromRecordset method
objXLSheet.Range(strRange).CopyFromRecordset rs
objXLSheet.Columns.AutoFit

Set objXLSheet = Nothing

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!END LOOP
HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!­!!!!!!!!!!!!!!!!!!!!!!!!
'Save wb
objXLWb.Save
objXLWb.Close

'close up other rs objects
rs.Close
Set rs = Nothing
Set objXLWb = Nothing

'quitExcel
objXLApp.Quit
Set objXLApp = Nothing

DoCmd.Hourglass False
Exit Sub

Select Case Err
Case 9 'Worksheet doesn't exist
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet

Resume Next

Case 1004 'Workbook doesn't exist, make it
objXLApp.Workbooks.Add
Set objXLWb = objXLApp.ActiveWorkbook
objXLWb.SaveAs strWorkBook

Resume Next

Case Else
DoCmd.Hourglass False
MsgBox Err.Number & " " & Err.Description
Stop
Resume 0
End Select

End Sub

BTW: my code to execute this w/ query sql is: CopyRs2SheetHacked
"SELECT tblProducts.Catalog, tblProducts.MaterialNumber,
tblProducts.Manufacturer, tblProducts.GMR, tblProducts.Category,
tblProducts.Description, tblProducts.[Sub-Category],
tblProducts.SortOrder, tblProducts.AddedNote, tblProducts.Required,
tblProducts.NoList, tblProducts.Hyper_Link, tblProducts.ProductID,
tblProducts.Deleted, tblProducts.Cost From tblProducts WHERE
(((tblProducts.Manufacturer) Is Not Null And
(tblProducts.Manufacturer) Like " & strManuf & ") AND
((tblProducts.Deleted)=False));", CurrentProject.Path & "\E-
Catalog.xls", strManuf, "A2"

I am sure I forgot to mention something, but I really appreciate your
help!
Thanks,
Matt Pierringer

I didn't make my situation as clear as I could have. What I have
right now is I am able to make a workbook fromexcelpopulate a
dynamicsheetinexcel. The problem I have is I have a query list of
manufacturers that I want to run through and make a newsheetfor each
of them(Currently I only have one). I inserted the string in the spot
where it needs to go to get a new list from the manufactuer, but I
don't know how to loop through the list.

strManuf = should be an array of manufacturer names, probably up to 15
or so.

I appreciate anyones suggestions for how to go about doing this,

Thanks,
Matt

Ok, I got a little further with using DAO, but I know this isn't very
close yet. I am trying to get the variables set up right so that it
is only reading column "Manufacturers" in qryManufacturers where my
DAO is getting reading the records to get a variable to put into sql
for the other query. ANYONE up for what seems to be a challenge
because no one has responded in the past 2 days????

Public Sub CopyRs2SheetHacked(strSql As String, strWorkBook As String,
_
Optional strWorkSheet As String, Optional strRange As
String)
'Uses the Excel CopyFromRecordset method
'strSql: Sql Select string
'strWorkBook: Full path and name to target wb, will create
if doesn 't exist
'strWorkSheet: Name of target worksheet, will create if
doesn't exist
'strRange: Upper left cell for data, defaults to A2

On Error GoTo ProcError

DoCmd.Hourglass True

Dim objXLApp As Object 'Excel.Application
Dim objXLWb As Object 'Excel.Workbook
Dim objXLSheet As Object 'Excel.Worksheet
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim i As Integer
Dim lvlColumn As Integer
Dim db As Database
Dim rsQuery As Recordset 'The query I am getting the
Manufacturers from
Dim CurrMan As Recordset


'YourFunction (rsQuery!Manufacturers)


'set rs from sql, table or query
Set rs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset)
'dbOpenSnapshot

'start Excel
Set objXLApp = New Excel.Application

'open workbook, error routine will
'create it if doesn't exist
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)

'select a worksheet, if sheet doesn't exist
'the error routine will add it
'ME: Try to get Worksheet names, to loop through
qryManufacturers
'If strWorkSheet = "" Then
' strWorkSheet = "Sheet1"
'End If

'If Range is missing default to A1
If strRange = "" Then
strRange = "A2"
End If

''''''For Loop to go through and create every sheet for every
manufacturer
Set db = CurrentDb
Set rsQuery = db.OpenRecordset("qryManufacturers")
Set CurrMan = rsQuery!Manufacturers
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Start Loop
Here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Do Until CurrMan = rsQuery.EOF

'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)

'ME: add column headers from sql query
For lvlColumn = 0 To rs.Fields.Count - 1
objXLSheet.Cells(1, lvlColumn + 1).Value = _
rs.Fields(lvlColumn).Name
Next

'bold header row
objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Font.Bold = True
'put border around header row
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1,
rs.Fields.Count)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With objXLSheet.Range(objXLSheet.Cells(1, 1), _
objXLSheet.Cells(1, rs.Fields.Count)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'insert recordset into Excel Worksheet using
CopyFromRecordset method
objXLSheet.Range(strRange).CopyFromRecordset rs
objXLSheet.Columns.AutoFit



Set objXLSheet = Nothing
Set CurrMan = rsQuery.MoveNext
Loop

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!END LOOP
HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Save wb
objXLWb.Save
objXLWb.Close

'close up other rs objects
rs.Close
rsQuery.Close
Set rs = Nothing
Set objXLWb = Nothing
Set CurrMan = Nothing

'quit Excel
objXLApp.Quit
Set objXLApp = Nothing

DoCmd.Hourglass False
Exit Sub

ProcError:

Select Case Err
Case 9 'Worksheet doesn't exist
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet

Resume Next

Case 1004 'Workbook doesn't exist, make it
objXLApp.Workbooks.Add
Set objXLWb = objXLApp.ActiveWorkbook
objXLWb.SaveAs strWorkBook

Resume Next

Case Else
DoCmd.Hourglass False
MsgBox Err.Number & " " & Err.Description
Stop
Resume 0
End Select

End Sub


////////////////////////////////////////////////////////////////////////////////////////////////
Here is the function I am calling it with:
CopyRs2SheetHacked "SELECT tblProducts.Catalog,
tblProducts.MaterialNumber, tblProducts.Manufacturer, tblProducts.GMR,
tblProducts.Category, tblProducts.Description, tblProducts.[Sub-
Category], tblProducts.SortOrder, tblProducts.AddedNote,
tblProducts.Required, tblProducts.NoList, tblProducts.Hyper_Link,
tblProducts.ProductID, tblProducts.Deleted, tblProducts.Cost From
tblProducts WHERE (((tblProducts.Manufacturer) Is Not Null And
(tblProducts.Manufacturer) Like " & strManuf & ") AND
((tblProducts.Deleted)=False));", CurrentProject.Path & "\GraybarE-
Catalog.xls", CurrMan, "A2"




Thanks,
Matt