Exporting Reports with subreports to excel

So sorry,

i sent it from my work email.

thanks,
 
Okay, I see the problem, it's two-fold. You put the Function in a separate Module when it needed to be behind the From and then I had two typos. So, copy/paste the below behind the Form BOM DETAILS PLUS under End Sub and delete Module1.

Code: 
 Function SendToExcel(strTQName As String, strSheetName As String)
 ' strTQName is the name of the table or query you want to send to Excel
 ' strSheetName is the name of the sheet you want to send it to
     
         Dim rst As DAO.Recordset
         Dim ApXL As Object
         Dim xlWBk As Object
         Dim xlWSh As Object
         Dim fld As DAO.Field
         Dim lngMaxRow As Long
         Dim lngMaxCol As Long
         Dim strPath As String
     
         On Error GoTo Err_Handler
             'Location of Template
             strPath = "G:\SUE'S STUFF\WORKING DESKTOP\2016 WESTLAND\WESTLAND EXPORT\Book1.xls"
  
             Set rst = CurrentDb.OpenRecordset(strTQName)
             Set ApXL = CreateObject("Excel.Application")
         
         
             Set xlWBk = ApXL.Workbooks.Open(strPath)
             ApXL.Visible = True
                 
              Set xlWSh = xlWBk.Worksheets(strSheetName)
            xlWSh.Range("I1").Value = Me.ID
            xlWSh.Range("I2").Value = Me.[COVER PART NUMBER]
            xlWSh.Range("I3").Value = Me.[MODELS.DESCRIPTION]
  
             rst.MoveFirst
             xlWSh.Range("A8").CopyFromRecordset rst
             ' selects the first cell to unselect all cells
             xlWSh.Range("A8").Select
         
         xlWSh.Activate
         xlWSh.Cells.Rows(7).AutoFilter
         xlWSh.Cells.Rows(7).EntireColumn.AutoFit
     
         rst.Close
         Set rst = Nothing
         'Remove prompts to save the report
         ApXL.DisplayAlerts = False
         xlWBk.SaveAs "N:\EXACT FIT\WESTLAND EXPORT PLUS\Westland_" & Format(Date, "mm.dd.yyyy") & ".xlsx", 51
         ApXL.DisplayAlerts = True
         'ApXL.Quit
     
         Exit Function
Err_Handler:
         DoCmd.SetWarnings True
         MsgBox Err.DESCRIPTION, vbExclamation, Err.Number
         Exit Function
  
  End Function


Once you do that run again and let me know...
 
Go to the Form in Design View then click the *View Code* button on the Ribbon (Design tab) and that is where you copy it.
 
OMG....this worked thank you thank you....now we have to do the other 2 codes right....
 
Okay, so that part is working...

Will the second part ALWAYS start on line 29? In other words the first part will NEVER go past 20 lines?
 
Okay then will work on the next part in a bit... I'm hungry and I just got an urgent eMail from a Client.
 
Oops, forgot, the first two queries are identical, do the follow each other in the first 20 lines?

I can see the third query goes to the bottom section... is that correct?
 
Yes the first 2 have identical headings n 2nd can fillow the 1st..the 3rd has different headings

Ty
 
This is going to be a step by step because I had to make some changes and I'm going to do this is separate posts so less confusion.

Step one...
Create a new query, do not select and tables, just click *Cancel*. Then in the upper left hand corner select SQL View and copy/paste the below in the open window. Once done close and save and name quniExportToExcel.

Code: 
SELECT [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].ID, [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].[PART NUMBER], [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].[PART DESCRIPTION], [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].SUPPLIER, [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].COO, [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].[COST W FREIGHT], [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].UOM, [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].QUANITY, [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT].Expr1
FROM [BOM PRICING EXTENDED DETAILS NON BOW S EXPORT]
UNION SELECT [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].ID, [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].[PART NUMBER], [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].[PART DESCRIPTION], [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].SUPPLIER, [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].COO, [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].[COST W FREIGHT], [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].UOM, [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].QUANITY, [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT].Expr1
FROM [BOM PRICING EXTENDED DETAILS PACKAGING S EXPORT];

When done post back.
 
Now, open Form BOM DETAILS PLUS and Select ALL and delete then copy/paste the below...

Code: 
Option Compare Database
Option Explicit
 Private Sub Command579_Click()
          Dim dbs As DAO.Database
         Dim qryDef As DAO.QueryDef
         Dim qryDefFooter As DAO.QueryDef
         Dim strSQL As String
         Dim strSQLFooter
         Dim strWhere As String
         Dim lngLen As Long
         Set dbs = CurrentDb
     
     strSQL = "SELECT ID, [PART NUMBER], [PART DESCRIPTION], SUPPLIER, COO, [COST W FREIGHT], UOM, QUANITY, Expr1 " & _
                "FROM quniExportToExcel"
                
     strSQLFooter = "SELECT ID, [PART NUMBER], QUANITY, Expr4 " & _
                        "FROM [BOM PRICING EXTENDED DETAILS LABOR S]"
     
     'Number
     If Not IsNull(Me.ID) Then
         strWhere = strWhere & "([ID] = " & Me.ID & ") AND "
     End If
     
     lngLen = Len(strWhere) - 5
     
     If lngLen <= 0 Then
         strSQL = strSQL
         Set qryDef = dbs.CreateQueryDef("qryWestportExport", strSQL)
         'DoCmd.OpenQuery qryDef.Name
         qryDef.Close
         Set qryDef = Nothing
         Call SendToExcel("qryWestportExport", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExport"
        DoEvents
         strSQLFooter = strSQLFooter
         Set qryDefFooter = dbs.CreateQueryDef("qryWestportExportFooter", strSQLFooter)
         'DoCmd.OpenQuery qryDef.Name
         qryDefFooter.Close
         Set qryDefFooter = Nothing
         Call SendToExcelFooter("qryWestportExportFooter", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExportFooter"
     Else
         strWhere = Left$(strWhere, lngLen)
         strSQL = strSQL & " WHERE " & strWhere
         Set qryDef = dbs.CreateQueryDef("qryWestportExport", strSQL)
         'DoCmd.OpenQuery qryDef.Name
         qryDef.Close
         Set qryDef = Nothing
         Call SendToExcel("qryWestportExport", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExport"
        DoEvents
         strSQLFooter = strSQLFooter & " WHERE " & strWhere
         Set qryDefFooter = dbs.CreateQueryDef("qryWestportExportFooter", strSQLFooter)
         'DoCmd.OpenQuery qryDef.Name
         qryDefFooter.Close
         Set qryDefFooter = Nothing
        Call SendToExcelFooter("qryWestportExportFooter", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExportFooter"
     End If
     
         dbs.Close
         Set dbs = Nothing
 End Sub
Function SendToExcel(strTQName As String, strSheetName As String)
 ' strTQName is the name of the table or query you want to send to Excel
 ' strSheetName is the name of the sheet you want to send it to
     
         Dim rst As DAO.Recordset
         Dim ApXL As Object
         Dim xlWBk As Object
         Dim xlWSh As Object
         Dim fld As DAO.Field
         Dim lngMaxRow As Long
         Dim lngMaxCol As Long
         Dim strPath As String
     
         On Error GoTo Err_Handler
             'Location of Template
             strPath = "G:\SUE'S STUFF\WORKING DESKTOP\2016 WESTLAND\WESTLAND EXPORT\Book1.xls"
  
             Set rst = CurrentDb.OpenRecordset(strTQName)
             Set ApXL = CreateObject("Excel.Application")
         
         
             Set xlWBk = ApXL.Workbooks.Open(strPath)
             ApXL.Visible = True
                 
              Set xlWSh = xlWBk.Worksheets(strSheetName)
            xlWSh.Range("I1").Value = Me.ID
            xlWSh.Range("I2").Value = Me.[COVER PART NUMBER]
            xlWSh.Range("I3").Value = Me.[MODELS.DESCRIPTION]
  
             rst.MoveFirst
             xlWSh.Range("A8").CopyFromRecordset rst
         
         rst.Close
         Set rst = Nothing
         'Remove prompts to save the report
         ApXL.DisplayAlerts = False
         xlWBk.SaveAs "N:\EXACT FIT\WESTLAND EXPORT PLUS\Westland_" & Format(Date, "mm.dd.yyyy") & ".xlsx", 51
         ApXL.DisplayAlerts = True
         'ApXL.Quit
     
         Exit Function
Err_Handler:
         DoCmd.SetWarnings True
         MsgBox Err.DESCRIPTION, vbExclamation, Err.Number
         Exit Function
  
  End Function
Function SendToExcelFooter(strTQName As String, strSheetName As String)
 ' strTQName is the name of the table or query you want to send to Excel
 ' strSheetName is the name of the sheet you want to send it to
     
         Dim rst As DAO.Recordset
         Dim ApXL As Object
         Dim xlWBk As Object
         Dim xlWSh As Object
         Dim fld As DAO.Field
         Dim lngMaxRow As Long
         Dim lngMaxCol As Long
         Dim strPath As String
     
         On Error GoTo Err_Handler
             'Location of Workbook
             strPath = "N:\EXACT FIT\WESTLAND EXPORT PLUS\Westland_" & Format(Date, "mm.dd.yyyy") & ".xlsx"
  
             Set rst = CurrentDb.OpenRecordset(strTQName)
             Set ApXL = CreateObject("Excel.Application")
             Set xlWBk = ApXL.Workbooks.Open(strPath)
             Set xlWSh = xlWBk.Worksheets(strSheetName)
            
             rst.MoveFirst
             xlWSh.Range("A29").CopyFromRecordset rst
             ' selects the first cell to unselect all cells
             xlWSh.Range("A8").SELECT
         
         xlWSh.Activate
         xlWSh.Cells.Rows(7).AutoFilter
         xlWSh.Cells.Rows(7).EntireColumn.AutoFit
     
         rst.Close
         Set rst = Nothing
         'Remove prompts to save the report
         ApXL.DisplayAlerts = False
         xlWBk.Save
         ApXL.DisplayAlerts = True
         'ApXL.Quit
     
         Exit Function
Err_Handler:
         DoCmd.SetWarnings True
         MsgBox Err.DESCRIPTION, vbExclamation, Err.Number
         Exit Function
  
 End Function
Then close and save and run the test...
 
Last edited:
ok i ran the code a box came up saying Cannot access 'Westland_xlsx' so i clicked ok then another box came up saying 'Westland_xlsx' is a read only to save a copy, click ok, then give the workbook a new name in the save as dialog box. i clicked ok and the sheet opened and it looked good.
 
Okay, so it's a timing issue because if I read you correctly, the data got exported... is that correct?
 
Okay... again, remove what's there and replace with...

Code: 
 Option Compare Database
Option Explicit
Private Sub Command579_Click()
          Dim dbs As DAO.Database
         Dim qryDef As DAO.QueryDef
         Dim qryDefFooter As DAO.QueryDef
         Dim strSQL As String
         Dim strSQLFooter
         Dim strWhere As String
         Dim lngLen As Long
         Set dbs = CurrentDb
     
     strSQL = "SELECT ID, [PART NUMBER], [PART DESCRIPTION], SUPPLIER, COO, [COST W FREIGHT], UOM, QUANITY, Expr1 " & _
                "FROM quniExportToExcel"
                
     strSQLFooter = "SELECT ID, [PART NUMBER], QUANITY, Expr4 " & _
                        "FROM [BOM PRICING EXTENDED DETAILS LABOR S]"
     
     'Number
     If Not IsNull(Me.ID) Then
         strWhere = strWhere & "([ID] = " & Me.ID & ") AND "
     End If
     
     lngLen = Len(strWhere) - 5
     
     If lngLen <= 0 Then
         strSQL = strSQL
         Set qryDef = dbs.CreateQueryDef("qryWestportExport", strSQL)
         'DoCmd.OpenQuery qryDef.Name
         qryDef.Close
         Set qryDef = Nothing
         Call SendToExcel("qryWestportExport", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExport"
        DoEvents
         strSQLFooter = strSQLFooter
         Set qryDefFooter = dbs.CreateQueryDef("qryWestportExportFooter", strSQLFooter)
         'DoCmd.OpenQuery qryDef.Name
         qryDefFooter.Close
         Set qryDefFooter = Nothing
         Call SendToExcelFooter("qryWestportExportFooter", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExportFooter"
     Else
         strWhere = Left$(strWhere, lngLen)
         strSQL = strSQL & " WHERE " & strWhere
         Set qryDef = dbs.CreateQueryDef("qryWestportExport", strSQL)
         'DoCmd.OpenQuery qryDef.Name
         qryDef.Close
         Set qryDef = Nothing
         Call SendToExcel("qryWestportExport", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExport"
        DoEvents
         strSQLFooter = strSQLFooter & " WHERE " & strWhere
         Set qryDefFooter = dbs.CreateQueryDef("qryWestportExportFooter", strSQLFooter)
         'DoCmd.OpenQuery qryDef.Name
         qryDefFooter.Close
         Set qryDefFooter = Nothing
        Call SendToExcelFooter("qryWestportExportFooter", "Sheet1")
         DoCmd.DeleteObject acQuery, "qryWestportExportFooter"
     End If
     
         dbs.Close
         Set dbs = Nothing
 End Sub
Function SendToExcel(strTQName As String, strSheetName As String)
 ' strTQName is the name of the table or query you want to send to Excel
 ' strSheetName is the name of the sheet you want to send it to
     
         Dim rst As DAO.Recordset
         Dim ApXL As Object
         Dim xlWBk As Object
         Dim xlWSh As Object
         Dim fld As DAO.Field
         Dim lngMaxRow As Long
         Dim lngMaxCol As Long
         Dim strPath As String
     
         On Error GoTo Err_Handler
             'Location of Template
             strPath = "G:\SUE'S STUFF\WORKING DESKTOP\2016 WESTLAND\WESTLAND EXPORT\Book1.xls"
  
             Set rst = CurrentDb.OpenRecordset(strTQName)
             Set ApXL = CreateObject("Excel.Application")
         
         
             Set xlWBk = ApXL.Workbooks.Open(strPath)
             'ApXL.Visible = True
                 
              Set xlWSh = xlWBk.Worksheets(strSheetName)
            xlWSh.Range("I1").Value = Me.ID
            xlWSh.Range("I2").Value = Me.[COVER PART NUMBER]
            xlWSh.Range("I3").Value = Me.[MODELS.DESCRIPTION]
  
             rst.MoveFirst
             xlWSh.Range("A8").CopyFromRecordset rst
         
         rst.Close
         Set rst = Nothing
         'Remove prompts to save the report
         ApXL.DisplayAlerts = False
         xlWBk.SaveAs "N:\EXACT FIT\WESTLAND EXPORT PLUS\Westland_" & Format(Date, "mm.dd.yyyy") & ".xlsx", 51
         ApXL.DisplayAlerts = True
         ApXL.Quit
     
         Exit Function
Err_Handler:
         DoCmd.SetWarnings True
         MsgBox Err.DESCRIPTION, vbExclamation, Err.Number
         Exit Function
  
  End Function
Function SendToExcelFooter(strTQName As String, strSheetName As String)
 ' strTQName is the name of the table or query you want to send to Excel
 ' strSheetName is the name of the sheet you want to send it to
     
         Dim rst As DAO.Recordset
         Dim ApXL As Object
         Dim xlWBk As Object
         Dim xlWSh As Object
         Dim fld As DAO.Field
         Dim lngMaxRow As Long
         Dim lngMaxCol As Long
         Dim strPath As String
     
         On Error GoTo Err_Handler
             'Location of Workbook
             strPath = "N:\EXACT FIT\WESTLAND EXPORT PLUS\Westland_" & Format(Date, "mm.dd.yyyy") & ".xlsx"
  
             Set rst = CurrentDb.OpenRecordset(strTQName)
             Set ApXL = CreateObject("Excel.Application")
             Set xlWBk = ApXL.Workbooks.Open(strPath)
             Set xlWSh = xlWBk.Worksheets(strSheetName)
            
             ApXL.Visible = True
              rst.MoveFirst
             xlWSh.Range("A29").CopyFromRecordset rst
             ' selects the first cell to unselect all cells
             xlWSh.Range("A8").SELECT
         
         xlWSh.Activate
         xlWSh.Cells.Rows(7).AutoFilter
         xlWSh.Cells.Rows(7).EntireColumn.AutoFit
     
         rst.Close
         Set rst = Nothing
         'Remove prompts to save the report
         ApXL.DisplayAlerts = False
         xlWBk.Save
         ApXL.DisplayAlerts = True
         'ApXL.Quit
     
         Exit Function
Err_Handler:
         DoCmd.SetWarnings True
         MsgBox Err.DESCRIPTION, vbExclamation, Err.Number
         Exit Function
  
 End Function
 
You must log in or register to reply here.

Similar threads

F
Help request for creating Reports with pictures
Replies
3
Views
190
Mark_
M
S
Is there a way to have print/save options for filtered form without utilizing right click?
Replies
10
Views
479
Gasman
Gasman
Safaa
How to display a specific number of records in a subreport linked to the original report with the patient code
2
Replies
20
Views
732
Pat Hartman
P
F
Solved Mask with sub-mask filtered by 2 combined drop-down boxes and a checkbox, opening two different reports depending on the checkbox
Replies
6
Views
328
Faoineag
F
P
Solved current record PDF issues
2
Replies
23
Views
443
Pat Hartman
P

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom