Hi there hope you are doing well. I have been working hard on this myself and I really think I have got most of it figured out except this footer. Well it turns out I need it but in a different way. What I need is the data to across columns not down and i dont need the ID. Can you help.
There is only one time I need this footer. The other ones i dont so i still need to figure out how to get rid of it
I have attached the sample. The columns headings are BH - BM
HERE IS THE CURRENT CODE
Option Compare Database
Private Sub Command466_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[PART NUMBER], QUANITY " & _
"FROM quniExportToExcel"
strSQLFooter = "SELECT ID, [PART NUMBER], QUANITY " & _
"FROM [BOM PRICING EXTENDED DETAILS LABOR SEA RAY]"
'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 = "S:\Allfiles\GLBT\BOM EXPORT\Book5.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("A2").Value = Me.[FULL PART NUMBER]
xlWSh.Range("A3").Value = Me.[SEWING PART NUMBER]
xlWSh.Range("A4").Value = Me.[BOW KIT PART NUMBER]
xlWSh.Range("D2").Value = Me.[FULL DESCRIPTION]
xlWSh.Range("S2").Value = Me.[ITEM CLASS]
xlWSh.Range("BX2").Value = Me.[ITEM TYPE]
xlWSh.Range("AZ2").Value = Me.[UPC CODE]
xlWSh.Range("CD2").Value = Me.[LOCATION 1]
xlWSh.Range("CE2").Value = Me.[LOCATION 2]
xlWSh.Range("CH2").Value = Me.[MRP#]
xlWSh.Range("CW2").Value = Me.[NOTES]
rst.Close
Set rst = Nothing
'Remove prompts to save the report
ApXL.DisplayAlerts = False
xlWBk.SaveAs "S:\Allfiles\GLBT\BOM EXPORT\PART TABLE\SEARAYPART_" & 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 = "S:\Allfiles\GLBT\BOM EXPORT\PART TABLE\SEARAYPART_" & 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("A46").CopyFromRecordset rst
' selects the first cell to unselect all cells
xlWSh.Range("B2").SELECT
xlWSh.Activate
xlWSh.Cells.Rows(1).AutoFilter
xlWSh.Cells.Rows(1).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
THANK YOU SO MUCH