If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below. |
|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Looping through Query to create multiple sheets in excel- Just need the loop
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 |
#2
|
|||
|
|||
Looping through Query to create multiple sheets in excel- Just need the loop
On Mar 19, 6:06 pm, "Matt Pierringer" wrote:
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 |
#3
|
|||
|
|||
Looping through Query to create multiple sheets in excel- Just need the loop
On Mar 20, 10:24 am, "Matt Pierringer" wrote:
On Mar 19, 6:06 pm, "Matt Pierringer" wrote: 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 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 |
Thread Tools | |
Display Modes | |
|
|