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

Tech-Archive recommends: Fix windows errors by optimizing your registry

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 strWork*** 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
'strWork***: Name of target work***, 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 objXL*** As Object 'Excel.Work***
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 work***, if *** doesn't exist
'the error routine will add it
'ME: Try to get Work*** names, to loop through
qryManufacturers
'If strWork*** = "" Then
' strWorkSheet = "Sheet1"
'End If

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

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


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

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

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

'insert recordset into Excel Work*** using
CopyFromRecordset method
objXL***.Range(strRange).CopyFromRecordset rs
objXL***.Columns.AutoFit



Set objXL*** = 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 'Work*** doesn't exist
objXLWb.Worksheets.Add
Set objXL*** = objXLWb.Active***
objXL***.Name = strWork***

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

.

Quantcast