M
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
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