Query results as an excel workbook with formatting.

N

nosaj03

Registered User.
Local time
Today, 14:15
Joined
May 29, 2016
Messages
21
I currently have a function that generates an email outlook with a table from a query in my db. I need to add an excel attachment of the same query results with filtering of the column headings.

Can I use the export to excel functionality that is in Access and if so how do I add the filtering to the columns and create a function I can call in my existing code?
 
You can (with some care) link the excel worksheet as though it were a table, after which you could write some filtration queries to eliminate unwanted lines. For example, a "valid" line will have text in a particular set of cells, but a "divider" row might have blanks or nulls in those same cells. You might take it in layered queries, with one query doing the removal of unwanted lines and a second layer doing reformatting of the cells into more traditional formats.
 
This link shows how to add an attachment but what do you mean by "with filtering of the column headings". Could you give us a specific example?

It might also be helpful if you posted the code of the existing function.
 
sneuberg said:
This link shows how to add an attachment but what do you mean by "with filtering of the column headings". Could you give us a specific example?

It might also be helpful if you posted the code of the existing function.
Click to expand...

I apologize for the confusion. Basically what I need to do is allow the end user to be able to filter through the data in each column in the excel attachment. Once I figure out how to create the attachment to include in the email, I think I there is code to autofilter.

I checked the link you provided but it shows how to add the attachment but what would be the best way to create the excel worksheet from the query results.
 
If all else fails, I have a working Excel export procedure I wrote mainly as a proof-of-concept and partially to speed up future exports. It's rather more involved, however, than a simple DoCmd.OutputTo or DoCmd.TransferSpreadsheet, as it's meant to allow you to either use or replace an existing workbook, use or replace an existing worksheet, and place the top-left corner of the export in any position in the designated sheet. (It does not, however, check to see if you are going to run over the column limit, so that would be on you.)

If it's determined that neither OutputTo nor TransferSpreadsheet will work, I can post the code for you. If you go that route, then I would also strongly recommend you dig through the code to figure out precisely how it works.

On the bright side, mine exports using whichever version of Excel you have installed rather than one specific version.
 
nosaj03 said:
what would be the best way to create the excel worksheet from the query results.
Click to expand...

I do something similar The way I do it is
Obtain the recordset
Open an Excel template (this could have all your filters, formatting set ready?)
Populate the sheet(s) whilst moving through the recordset
Add any formulae I require
Save the completed file
Create an email and attach saved file.

All code gleaned from snippets on the net.
My code is in work, but I can post it up tomorrow if it would help?
 
Gasman said:
I do something similar The way I do it is
Obtain the recordset
Open an Excel template (this could have all your filters, formatting set ready?)
Populate the sheet(s) whilst moving through the recordset
Add any formulae I require
Save the completed file
Create an email and attach saved file.

All code gleaned from snippets on the net.
My code is in work, but I can post it up tomorrow if it would help?
Click to expand...

I actually wouldn't mind seeing that myself.
 
Gasman said:
I do something similar The way I do it is
Obtain the recordset
Open an Excel template (this could have all your filters, formatting set ready?)
Populate the sheet(s) whilst moving through the recordset
Add any formulae I require
Save the completed file
Create an email and attach saved file.

All code gleaned from snippets on the net.
My code is in work, but I can post it up tomorrow if it would help?
Click to expand...

Id like to see it.

I was thinking about creating a template but the naming convention of the file has to include a date and time stamp since the report will go out hourly. I figured I can create a new file every hour with the the date format in the event I need to refer to previous file for troubleshooting.
 
Frothingslosh said:
I actually wouldn't mind seeing that myself.
Click to expand...

OK, it is not the tidiest code, as it was created for a specific task, not a generic solution like yours, but I'll post it up tomorrow.

I think the key here is to create an Excel template with all the bells and whistles you need. One version I have has conditional formattiing of the cells set up ready.
 
nosaj03 said:
Id like to see it.

I was thinking about creating a template but the naming convention of the file has to include a date and time stamp since the report will go out hourly. I figured I can create a new file every hour with the the date format in the event I need to refer to previous file for troubleshooting.
Click to expand...

The template file can be named anything, it is just a place to start.
On one export my output file has the name of the company prepended to a standard name, and another has the weekend date prepended. The reason I do that way is to save mucking around with the file suffixes :)
 
Okay, well, here's mine. It's basically just plug-and-play, but the formatting is pretty minimal. If you have it export a header row, then the header is bolded, and you can have all the columns resized for you if you wish. Other than that, formatting is on you.

The constant PROJECT_NAME is one I use in pretty much everything I build for form and message box captions.

Also, apparently I need to go back and finish commenting it. :D

Code: 
Public Constant PROJECT_NAME = "Insert Project/Application Name Here"

Public Function ExportToExcel(ByRef rs As DAO.Recordset, _
                              ByVal OutputPath As String, _
                              Optional ByVal TopLeft As String = "A1", _
                              Optional ByVal SheetName As String = "Sheet 1", _
                              Optional ByVal ReplaceExisting As Boolean = False, _
                              Optional ByVal AddSheet As Boolean = False, _
                              Optional ByVal IncludeColumnNames As Boolean = False, _
                              Optional ByVal AutoFitData As Boolean = True) As Integer
[COLOR="Green"]'*************************************************
'Created By:            Frothingslosh
'Date Created:          6/8/2016
'Revised By:            Frothingslosh
'Date Revised:          8/23/2016
'Purpose:               Exports a recordset to Excel.
'Parameters:            An open recordset containing the data to be exported
'                       A string containing the full path for the file to be appended or created
'                       Optional - The location of the top-left cell for the exported dataset.  Defaults to "A1".
'                       Optional - The name of the created worksheet.  Defaults to 'Sheet 1'.
'                       Optional - Whether or not to replace any existing workbook of the same name and location.  Defaults to FALSE.
'                       Optional - Whether or not to add the recordset as a new worksheet if the destination workbook already exists.  Defaults to FALSE.
'			Optional - Whether or not to include the column names as a header row.  Defaults to FALSE.
'			Optional - Whether or not the columns get rezised after the export is complete.  Defaults to TRUE.
'Returns:               Success/Failure Code:
'                       0   - Uncaught/unhandled exception
'                       1   - Output file already exists, user chose to cancel rather than replace the file
'                       2   - Output sheet already exists in output file and user chose to cancel
'                       3   - Output file already exists and is locked
'                       999 - Successful save
'Dependencies:          Requires CheckFileLock procedure
'                       Requires FileExists procedure
'Comments:
'*************************************************[/COLOR]
On Error GoTo E2E_Err

Dim wb As Object
Dim ws As Object
Dim xl As Object
Dim MsgResponse As Variant          [COLOR="green"]'Returned value from any instance of the MsgBox function[/COLOR]
Dim OutputExists As Boolean         [COLOR="green"]'Whether or not the destination file already exists[/COLOR]
Dim wsName As Variant               [COLOR="green"]'Used to check worksheet names[/COLOR]
Dim NewSheetName As String          [COLOR="green"]'Used to save a new worksheet name in case SheetName must be changed.[/COLOR]

[COLOR="green"]    'Defaults
    
    'Determine whether or not target workbook already exists.[/COLOR]
    If FileExists(OutputPath) Then
[COLOR="green"]        'File exists.  Check to see if ReplaceExisting is set to TRUE.[/COLOR]
        If Not ReplaceExisting Then
[COLOR="green"]            'ReplaceExisting is not set to true - check AddSheet (if RE is FALSE and AS is TRUE, there is no reason to query the user.)[/COLOR]
            If Not AddSheet Then
[COLOR="green"]                'Ask the user if they want to replace the existing file.[/COLOR]
                Select Case MsgBox("File already exists; replace?", vbYesNo + vbCritical + vbDefaultButton2, PROJECT_NAME)
                    Case vbYes
[COLOR="green"]                        'User okayed replacing the file, so change the RE flag to TRUE.[/COLOR]
                        ReplaceExisting = True
                    Case vbNo
[COLOR="green"]                        'User does not want to replace the file.  Determine if they want to add the data to the existing file in a new worksheet.[/COLOR]
                        If MsgBox("Do you wish to add a worksheet to the existing file with this data?", vbYesNoCancel + vbInformation + vbDefaultButton3, [COLOR="green"]PROJECT_NAME) = vbYes Then
                            'Change the AddSheet flag to TRUE[/COLOR]
                            AddSheet = True
                        Else
[COLOR="green"]                            'User chose to neither kill the existing file nor add a sheet to it.  Return result code and terminate processing.[/COLOR]
                            ExportToExcel = 1
                            Err.Raise 500
                        End If
                    Case Else
[COLOR="green"]                        'User either closed the message box or selected 'Cancel'.  Return result code and terminate processing.[/COLOR]
                        ExportToExcel = 1
                        Err.Raise 500
                End Select
            End If
        End If
        
[COLOR="green"]        'Determine if the destination file is locked.[/COLOR]
        If CheckFileLock(OutputPath) Then
[COLOR="green"]            'File is in use.  Return error code and terminate processing.[/COLOR]
            ExportToExcel = 3
            Err.Raise 500
        End If
        
[COLOR="green"]        'File is not locked.  Check value of ReplaceExisting.[/COLOR]
        If ReplaceExisting Then
[COLOR="green"]            'File is to be replaced.  Delete the existing copy.[/COLOR]
            Kill OutputPath
[COLOR="green"]            'Open Excel.[/COLOR]
            Set xl = CreateObject("Excel.Application")
[COLOR="green"]            'Create the output workbook.[/COLOR]
            Set wb = xl.Workbooks.Add
[COLOR="green"]            'Save the workbook.[/COLOR]
            wb.SaveAs OutputPath
        Else
[COLOR="green"]            'File is NOT to be replaced, and AddSheet has been selected.[/COLOR]
            'Open Excel.
            Set xl = CreateObject("Excel.Application")
[COLOR="green"]            'Open the output workbook.[/COLOR]
            Set wb = xl.Workbooks.Open(OutputPath)
[COLOR="green"]            'Check to see if the worksheet name provided already exists.[/COLOR]
            For Each wsName In wb.Sheets
                If wsName = SheetName Then
                    Select Case MsgBox("The worksheet '" & SheetName & "' already exists.  Do you wish to replace it?", vbCritical + vbYesNoCancel + vbDefaultButton3, PROJECT_NAME)
                        Case vbYes
[COLOR="green"]                            'User chose to replace the existing sheet.  Delete it.[/COLOR]
                            wb.Sheets(wsName).Delete
[COLOR="green"]                            'Mission accomplished - exit the loop.[/COLOR]
                            Exit For
                        Case vbNo
[COLOR="green"]                            'User does not want to replace the existing sheet.  Ask if they want to use a different sheet name.[/COLOR]
                            If MsgBox("Do you wish to use a different name than '" & SheetName & "'?", vbCritical + vbYesNo + vbDefaultButton2, PROJECT_NAME) = vbYes Then
[COLOR="green"]                                'User selected YES.  Ask the user for a new worksheet name.[/COLOR]
                                NewSheetName = InputBox("Please enter new worksheet name.  Leave blank to cancel.", PROJECT_NAME)
[COLOR="green"]                                'Begin a loop.[/COLOR]
                                Do
                                    If NewSheetName = "" Then
[COLOR="green"]                                        'User did not enter a name.  Return result code and terminate execution.[/COLOR]
                                        ExportToExcel = 2
                                        Err.Raise 500
                                    ElseIf NewSheetName = SheetName Then
[COLOR="green"]                                        'User entered the already-taken worksheet name.  Notify the user that the name must be different.[/COLOR]
                                        MsgBox "New name must not be '" & SheetName & "'.", vbCritical + vbOKOnly, PROJECT_NAME
[COLOR="green"]                                        'Ask the user for a new worksheet name.[/COLOR]
                                        NewSheetName = InputBox("Please enter new worksheet name.  Leave blank to cancel.", PROJECT_NAME)
                                    End If
                                Loop Until NewSheetName <> "" And NewSheetName <> SheetName
[COLOR="green"]                                'Update SheetName with the newly selected name.[/COLOR]
                                SheetName = NewSheetName
                            Else
[COLOR="green"]                                'User chose not to use a different name.  Return result code and terminate execution.[/COLOR]
                                ExportToExcel = 2
                                Err.Raise 500
                            End If
                        Case vbCancel
[COLOR="green"]                            'User chose to cancel the process.  Return result code and terminate execution.[/COLOR]
                            ExportToExcel = 2
                            Err.Raise 500
                    End Select
                End If
            Next wsName
        End If
        
[COLOR="green"]        'Either wb is a brand new workbook or else there is no (further) conflict with SheetName.  Create the output worksheet.[/COLOR]
        Set ws = wb.Worksheets.Add(wb.Worksheets(1))
[COLOR="green"]        'Save the workbook.[/COLOR]
        wb.Save
    Else
[COLOR="green"]        'Output file doesn't already exist, so create it.
        'Open Excel.[/COLOR]
        Set xl = CreateObject("Excel.Application")
[COLOR="green"]        'Create the output workbook.[/COLOR]
        Set wb = xl.Workbooks.Add
[COLOR="green"]        'Select the first (and usually only) sheet in the new workbook as ws.[/COLOR]
        Set ws = wb.Sheets(1)
[COLOR="green"]        'Set the name of the worksheet to SheetName.[/COLOR]
        ws.Name = SheetName
[COLOR="green"]        'Save the workbook.[/COLOR]
        wb.SaveAs OutputPath
    End If

    Dim CurrentRow As Long
    Dim CurrentColumn As Long
    
    CurrentRow = ws.Range(TopLeft).Row
    CurrentColumn = ws.Range(TopLeft).Column
    
[COLOR="green"]    'Determine if column names are to be transferred.[/COLOR]
    If IncludeColumnNames Then
[COLOR="green"]        'NOTE - ADD COMMENTS HERE!!![/COLOR]
        Dim ColCount As Long
        For ColCount = 0 To rs.Fields.Count - 1
            ws.Cells(CurrentRow, ColCount + 1).value = rs.Fields(ColCount).Name
        Next ColCount
        ws.Range(xl.Cells(CurrentRow, CurrentColumn), xl.Cells(CurrentRow, CurrentColumn + rs.Fields.Count - 1)).Font.Bold = True
        CurrentRow = CurrentRow + 1
    End If
    
[COLOR="green"]    'Copy the submitted recordset to the output spreadsheet.[/COLOR]
    ws.Cells(CurrentRow, CurrentColumn).CopyFromRecordset rs
    
[COLOR="green"]    'Check to see if the exported data columns should be resized.[/COLOR]
    If AutoFitData Then
[COLOR="green"]        'Resize the rows to fit.[/COLOR]
        ws.UsedRange.Columns.AutoFit
    End If
    
[COLOR="green"]    'Save the workbook.[/COLOR]
    wb.Save
    
[COLOR="green"]    'Return a 'Success' result[/COLOR]
    ExportToExcel = 999
    
E2E_Exit:
    On Error Resume Next
    If Not ws Is Nothing Then Set ws = Nothing
    If Not wb Is Nothing Then
        wb.Close
        Set wb = Nothing
    End If
    If Not xl Is Nothing Then
        xl.Quit
        Set xl = Nothing
    End If
    Exit Function
    
E2E_Err:
    Select Case Err.Number
        Case 500            [COLOR="green"]'User-defined error number.  Used here to terminate processing after validation failure or user cancelling export.[/COLOR]
            Resume E2E_Exit
        Case Else           [COLOR="green"]'All other errors[/COLOR]
            Beep
            MsgBox ERR_START & _
                "Function:" & vbTab & vbTab & "modFileUtilities.ExportToExcel" & vbCrLf & _
                "Err Number: " & vbTab & Err.Number & vbCrLf & _
                "Description: " & vbTab & Err.Description, vbCritical, PROJECT_NAME
            Resume E2E_Exit
    End Select

End Function

Function CheckFileLock(FilePath As String) As Boolean
    On Error Resume Next
[COLOR="green"]    ' If the file is already opened by another process,
    ' and the specified type of access is not allowed,
    ' the Open operation fails and an error occurs.[/COLOR]
    Open FilePath For Binary Access Read Write Lock Read Write As #1
    Close #1
[COLOR="green"]    ' If an error occurs, the document is currently open.[/COLOR]
    If Err.Number <> 0 Then
[COLOR="green"]        ' Display the error number and description.[/COLOR]
        CheckFileLock = True
        Err.Clear
    Else
        CheckFileLock = False
    End If
End Function

Function FileExists(ByVal strFile As String, _
                    Optional bFindFolders As Boolean) As Boolean
[COLOR="green"]    'Purpose:   Return True if the file exists, even if it is hidden.
    'Arguments: strFile: File name to look for. Current directory searched if no path included.
    '           bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
    'Note:      Does not look inside subdirectories for the file.
    'Author:    Allen Browne. http://allenbrowne.com June, 2006.[/COLOR]
    Dim lngAttributes As Long

[COLOR="green"]    'Include read-only files, hidden files, system files.[/COLOR]
    lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)

    If bFindFolders Then
        lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
    Else
[COLOR="green"]        'Strip any trailing slash, so Dir does not look inside the folder.[/COLOR]
        Do While Right$(strFile, 1) = "\"
            strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If

[COLOR="green"]    'If Dir() returns something, the file exists.[/COLOR]
    On Error Resume Next
    FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
 
OK, here is the first routine I created

Hope it helps someone.

Code: 
Sub Export2XL(pstrType, plngSubmitterID)
On Error GoTo Err_Handler

Dim db As Database
Dim xlApp As Excel.Application
Dim xlWrkBk As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim rstTrades As Recordset, rstIntro As Recordset, rstPayments As Recordset
Dim strSQL As String, strSQLDate As String, strDBpath As String, strFolder As String, strPaymentsPath As String, strSQLPayments As String
Dim strSubmitterName As String, strEmail As String, strInvoiceFile As String, strSubject As String, strMessage As String, strSubjectEmail As String
Dim lSubmitterID As Long, lxlRow As Long
Dim strTestPrefix As String
Dim blnEmail As Boolean
Dim curPaid As Currency, curAdvance As Currency, curPrevious As Currency, curInvoice As Currency, curAdj As Currency
'Const strcJetDate = "\#mm\/dd\/yyyy\#"  'Needed for dates in queries as Access expects USA format.Now Public

' Set for testing, remove when live
strTestPrefix = "Test DB "
blnEmail = TempVars("gbEmail")
' Set messages and subject depending on what has been passed
Select Case pstrType
    Case "Invoice"
        strSubject = strTestPrefix & "Invoice Request"
        strMessage = "Would you please supply an invoice for the attached transactions?"
    Case "Update"
        strSubject = strTestPrefix & "Trade Update"
        strMessage = "Please find attached your latest client trades update."
End Select

'strMessage = "Would you please supply an invoice for the attached transactions?"

Set db = CurrentDb()
strDBpath = GetDBPath

'Create new folder if it does not exist
strFolder = Format(Now(), "yyyy-mm-dd")
strPaymentsPath = strDBpath & pstrType & "\" & strFolder & "\"

' Test for path to save files, created each week.
If Dir(strPaymentsPath, vbDirectory) = "" Then
    MkDir strPaymentsPath
End If


'Open and reference an instance of the Excel app
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False

' First get all the Submitters that can have an Invoice Run
' if plngSubmitterID is 0 then we want ALL
If plngSubmitterID = 0 Then
    strSQL = "SELECT tblSubmitter.InvoiceRun, tblSubmitter.SubmitterName, tblSubmitter.SubmitterID, tblSubmitter.Email FROM tblSubmitter"
    strSQL = strSQL & " WHERE (((tblSubmitter.InvoiceRun)=True))"
    strSQL = strSQL & " ORDER BY tblSubmitter.SubmitterName;"
Else
    strSQL = "SELECT tblSubmitter.InvoiceRun, tblSubmitter.SubmitterName, tblSubmitter.SubmitterID, tblSubmitter.Email FROM tblSubmitter"
    strSQL = strSQL & " WHERE (((tblSubmitter.InvoiceRun)=True) AND (tblSubmitter.SubmitterID = " & plngSubmitterID & "))"
End If


Set rstIntro = db.OpenRecordset(strSQL, dbOpenDynaset)

' Any submitter to process?
If rstIntro.EOF Then
    MsgBox "No Submitters found for " & pstrType & " Run"
    GoTo ExitSub
End If

' Set date in correct format for query
strSQLDate = Format(TempVars("Invoicedate"), strcJetDate)

' We only need to set this string once for the whole run
strSQLPayments = "SELECT tblPayments.InvoiceDate, tblPayments.InvoiceAmount FROM tblPayments"
strSQLPayments = strSQLPayments & " WHERE (((tblPayments.InvoiceDate)= " & strSQLDate & " AND ((tblPayments.SubmitterID)= " & plngSubmitterID & ")))"


rstIntro.MoveFirst

Do While Not rstIntro.EOF
    'Debug.Print rstIntro.Fields("SubmitterName")
    strSubmitterName = rstIntro.Fields("SubmitterName")
    ' need to add submitter name to subject so we can see it in Outlook list
    strSubjectEmail = strSubject & " - " & strSubmitterName
    strEmail = rstIntro.Fields("Email")
    strInvoiceFile = strPaymentsPath & strTestPrefix & strSubmitterName & " " & pstrType & ".xlsx"
    ' Set submitterID for query
    lSubmitterID = rstIntro.Fields("SubmitterID")
    ' SQL is different depending on Update or Invoice run
    If pstrType = "Invoice" Then
        strSQL = "SELECT tblSVSTrades.TradeDate, tblSVSTrades.Forename, tblSVSTrades.Surname, tblSVSTrades.TradeType, tblSVSTrades.NetCost, tblSVSTrades.BuySell, tblSubmitter.SubmitterName, tblIntroCommission.IntroCommission,tblIntroCommission.Invoiceddate,tblIntroCommission.PaidDate  FROM tblSubmitter"
        strSQL = strSQL & " INNER JOIN (tblSubmitterClient INNER JOIN ((tblCommission INNER JOIN tblIntroCommission ON tblCommission.CommissionID = tblIntroCommission.CommissionID) INNER JOIN tblSVSTrades ON tblCommission.TradeID = tblSVSTrades.SVSTradesID) ON tblSubmitterClient.SubmitterClientID = tblIntroCommission.SubmitterClientID) ON tblSubmitter.SubmitterID = tblSubmitterClient.SubmitterID"
        strSQL = strSQL & " WHERE (((tblIntroCommission.InvoicedDate) = " & strSQLDate & ")  AND ((tblSubmitterClient.SubmitterID)= " & lSubmitterID & "))"
        strSQL = strSQL & " ORDER BY tblSVSTrades.SVSTradesID;"
    Else
        strSQL = "SELECT tblSVSTrades.TradeDate, tblClient.Forename, tblClient.Surname, tblSVSTrades.TradeType, tblSVSTrades.NetCost,  tblSVSTrades.BuySell, tblSubmitter.SubmitterName,tblIntroCommission.IntroCommission, tblIntroCommission.InvoicedDate, tblIntroCommission.PaidDate FROM (tblCommission"
        strSQL = strSQL & " RIGHT JOIN ((tblClient INNER JOIN (tblSubmitter INNER JOIN tblSubmitterClient ON tblSubmitter.SubmitterID = tblSubmitterClient.SubmitterID) ON tblClient.ClientID = tblSubmitterClient.ClientID)"
        strSQL = strSQL & " INNER JOIN tblSVSTrades ON tblClient.SVS_Account = tblSVSTrades.SVSAccount) ON tblCommission.TradeID = tblSVSTrades.SVSTradesID) LEFT JOIN tblIntroCommission ON tblCommission.CommissionID = tblIntroCommission.CommissionID"
        strSQL = strSQL & " WHERE (((tblSubmitter.SubmitterID)=" & lSubmitterID & "))"
        strSQL = strSQL & " ORDER BY tblSVSTrades.SVSTradesID"
    End If


    Set rstTrades = db.OpenRecordset(strSQL, dbOpenDynaset)

    If Not (rstTrades.BOF And rstTrades.EOF) Then
        ' Open the Excel Template file
        Set xlWrkBk = xlApp.Workbooks.Open(strDBpath & "Introducer Export.xltx")
        'reference the first sheet in the file
        Set xlSht = xlWrkBk.Sheets(1)
        rstTrades.MoveFirst
        strSubmitterName = rstTrades.Fields("SubmitterName")
        'Update status bar with progress
        SetStatusBar ("Retrieving Invoice data for " & strSubmitterName)
    
        lxlRow = 3
        Do While Not rstTrades.EOF
            ' Now enter values in sheet
            xlSht.Cells(lxlRow, 1) = rstTrades.Fields("TradeDate")
            xlSht.Cells(lxlRow, 2) = rstTrades.Fields("Forename")
            xlSht.Cells(lxlRow, 3) = rstTrades.Fields("Surname")
            xlSht.Cells(lxlRow, 4) = rstTrades.Fields("TradeType")
            xlSht.Cells(lxlRow, 5) = rstTrades.Fields("NetCost")
            xlSht.Cells(lxlRow, 6) = rstTrades.Fields("BuySell")
            xlSht.Cells(lxlRow, 7) = rstTrades.Fields("SubmitterName")
            xlSht.Cells(lxlRow, 8) = rstTrades.Fields("IntroCommission")
            ' If in Update mode add relevant dates
            If pstrType = "Update" Then
                xlSht.Cells(lxlRow, 9) = rstTrades.Fields("InvoicedDate")
                xlSht.Cells(lxlRow, 10) = rstTrades.Fields("PaidDate")
            End If
            lxlRow = lxlRow + 1
            rstTrades.MoveNext
        Loop
        lxlRow = lxlRow + 2
        xlSht.Cells(lxlRow, 3) = "Date"
        xlSht.Cells(lxlRow, 4) = Date
        xlSht.Cells(lxlRow, 7) = "Total"
        xlSht.Cells(lxlRow, 8) = "=SUM(H3:H" & lxlRow - 2 & ")"
        ' as we have put the formula in excel we should be able ro read the value instead of summing it ourselves.
        curInvoice = xlSht.Cells(lxlRow, 8).Value
        
        ' Now check if Castle Invoice run and if so get extra values to apply to invoice
        If strSubmitterName = "Castle" Then
            curAdvance = GetCastleAmount("Advance")
            curPrevious = GetCastleAmount("Previous")
            curPaid = GetCastleAmount("Paid")
            curAdj = curPrevious - (curAdvance + curPaid)
            lxlRow = lxlRow + 2
            xlSht.Cells(lxlRow, 6) = "Fact Find Advance"
            xlSht.Cells(lxlRow, 6).Font.Bold = True
            xlSht.Cells(lxlRow, 8) = curAdj
            lxlRow = lxlRow + 2
            xlSht.Cells(lxlRow, 6) = "Final Invoice Balance"
            xlSht.Cells(lxlRow, 6).Font.Bold = True
            xlSht.Cells(lxlRow, 8) = curInvoice + curAdj
        End If
        ' Now autofit columns
        xlApp.Columns("A:Z").EntireColumn.AutoFit
        SetStatusBar ("Saving Excel workbook " & strInvoiceFile)
        ' Now save the workbook
        xlWrkBk.SaveAs FileName:=strInvoiceFile
        xlWrkBk.Close
        'Now email the workbook to the Submitter if tempvars gbEmail is true
        If blnEmail Then
            Call Mail_Attachment(strEmail, strInvoiceFile, strSubjectEmail, strMessage)
        End If
    Else
        SetStatusBar ("No trades for " & strSubmitterName)
    End If
    ' Now close the recordset ready for the next
    rstTrades.Close
    ' Now update Payments table with date and value of invoice for submitter
    Set rstPayments = db.OpenRecordset(strSQLPayments, dbOpenDynaset)
    ' if BOF or EOF then this is the first time of running for this date and submitter
    With rstPayments
        If .BOF Or .EOF Then
            .AddNew
        Else
            .Edit
        End If
        .Fields("Invoicedate") = TempVars("Invoicedate")
        .Fields("InvoiceAmount") = curInvoice
        .Update
    End With
    rstPayments.Close

    ' Now get next record
    rstIntro.MoveNext
Loop
    

ExitSub:
    xlApp.DisplayAlerts = True
    Set db = Nothing
    Set rstIntro = Nothing
    Set rstTrades = Nothing
    Set rstPayments = Nothing
    Set xlSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    SetStatusBar (" ")

    
Err_Exit:
    Exit Sub
    
Err_Handler:
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume ExitSub
End Sub

and then I have just created another based on the first one
Code: 
Sub Export2XL(pdtDateWE, pblnMail As Boolean)
On Error GoTo Err_Handler

Dim db As Database
Dim xlApp As Excel.Application
Dim xlWrkBk As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim rstPR As Recordset, rstNS As Recordset, rstNL As Recordset
Dim strSQL As String, strSQLDate As String, strDBpath As String, strFolder As String, strExportPath As String, strSQLPayments As String
Dim strEmail As String, strXLTemplate As String, strXLFile As String, strSubject As String, strMessage As String, strSubjectEmail As String
Dim lSubmitterID As Long, lxlRow As Long
Dim strTestPrefix As String
Dim blnEmail As Boolean
Dim curPaid As Currency, curAdvance As Currency, curPrevious As Currency, curInvoice As Currency, curAdj As Currency
'Const strcJetDate = "\#mm\/dd\/yyyy\#"  'Needed for dates in queries as Access expects USA format.Now Public

' Set for testing, remove when live
strTestPrefix = ""
strSubject = strTestPrefix & "Payroll Data - Heartleys"
strMessage = "Please find attached the latest employee data for payroll WE " & pdtDateWE
strEmail = "*****@********.co.uk"

Set db = CurrentDb()
strDBpath = Left(GetBackEndPath, InStrRev(GetBackEndPath, "\"))
strSQLDate = Format(pdtDateWE, strcJetDate)
strStartDate = Format(DateAdd("d", -6, pdtDateWE), strcJetDate)

'Create new folder if it does not exist
strSuffix = Format(pdtDateWE, "yyyy-mm-dd")
strExportPath = strDBpath & "Payroll" & "\"

' Set up XL file names
strXLTemplate = "Payroll Template.xlsx"
strXLFile = strSuffix & " - " & "Payroll Data.xlsx"

' Test for path to save files, created each week.
If Dir(strExportPath, vbDirectory) = "" Then
    MkDir strExportPath
End If


'Open and reference an instance of the Excel app
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False

' Get all the records for week ending date
strSQL = "SELECT tblPayroll.*, [Forename] & ' ' & [Surname] AS Fullname"
strSQL = strSQL & " FROM tblEmployee INNER JOIN tblPayroll ON tblEmployee.EmployeeID = tblPayroll.EmployeeID"
strSQL = strSQL & " WHERE (((tblPayroll.DateWE)=" & strSQLDate & "))"

Set rstPR = db.OpenRecordset(strSQL, dbOpenDynaset)

' Any records to process?
If rstPR.EOF Then
    MsgBox "No records found for " & pdtDateWE
    GoTo ExitSub
End If

'Update status bar with progress
SetStatusBar ("Exporting payroll records to Excel file ")

rstPR.MoveFirst

' Open the Excel Template file
Set xlWrkBk = xlApp.Workbooks.Open(strExportPath & strXLTemplate)
'reference the first sheet in the file
Set xlSht = xlWrkBk.Sheets(1)
xlSht.Cells(2, 1) = rstPR![DateWE]
lxlRow = 3
Do While Not rstPR.EOF
    ' Now enter values in sheet
    xlSht.Cells(lxlRow, 2) = rstPR![FullName]
    xlSht.Cells(lxlRow, 3) = rstPR![BasicHours]
    xlSht.Cells(lxlRow, 4) = rstPR![OTHours]
    xlSht.Cells(lxlRow, 5) = rstPR![HolidayHours]
    xlSht.Cells(lxlRow, 6) = rstPR![BankHolidayHours]
    xlSht.Cells(lxlRow, 7) = rstPR![SickHours]
    xlSht.Cells(lxlRow, 8) = rstPR![Commission]
    xlSht.Cells(lxlRow, 9) = rstPR![BonusAmt]
    lxlRow = lxlRow + 1
    ' Now update the Processed date
     With rstPR
         .Edit
         ![Processed] = Date
         .Update
    End With
    rstPR.MoveNext
Loop
rstPR.Close
xlSht.Columns("A:Z").EntireColumn.AutoFit

' Now check for any starters
strSQL = "SELECT tblLookUp.DataValue AS RealTitle, tblEmployee.* "
strSQL = strSQL & " FROM tblEmployee LEFT JOIN tblLookup ON tblEmployee.Title = tblLookup.LookupID"
strSQL = strSQL & " WHERE (((tblEmployee.StartDate) Between " & strStartDate & " And " & strSQLDate & "))"

'Update status bar with progress
SetStatusBar ("Looking for new Starters")

Set rstNS = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rstNS.EOF Then
    Set xlSht = xlWrkBk.Sheets(2)
    lxlRow = 2
    rstNS.MoveFirst
    Do While Not rstNS.EOF
        xlSht.Cells(lxlRow, 1) = rstNS![RealTitle]
        xlSht.Cells(lxlRow, 2) = rstNS![Forename]
        xlSht.Cells(lxlRow, 3) = rstNS![Surname]
        xlSht.Cells(lxlRow, 4) = rstNS![Address1]
        xlSht.Cells(lxlRow, 5) = rstNS![Address2]
        xlSht.Cells(lxlRow, 6) = rstNS![Address3]
        xlSht.Cells(lxlRow, 7) = rstNS![Address4]
        xlSht.Cells(lxlRow, 8) = rstNS![Address5]
        xlSht.Cells(lxlRow, 9) = rstNS![PostCode]
        xlSht.Cells(lxlRow, 10) = rstNS![DOB]
        xlSht.Cells(lxlRow, 11) = rstNS![NINO]
        xlSht.Cells(lxlRow, 12) = rstNS![BasicRate]
        xlSht.Cells(lxlRow, 13) = rstNS![StartDate]
        rstNS.MoveNext
    Loop
    MsgBox "New Starter(s) found. Remember to forward HMRC Checklist Forms"
    rstNS.Close
End If
xlSht.Columns("A:Z").EntireColumn.AutoFit

' Now check for any leavers
strSQL = "SELECT tblLookUp.DataValue AS RealTitle, tblEmployee.* "
strSQL = strSQL & " FROM tblEmployee LEFT JOIN tblLookup ON tblEmployee.Title = tblLookup.LookupID"
strSQL = strSQL & " WHERE (((tblEmployee.EndDate) Between " & strStartDate & " And " & strSQLDate & "))"

'Update status bar with progress
SetStatusBar ("Looking for new Leavers")

Set rstNL = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rstNL.EOF Then
    Set xlSht = xlWrkBk.Sheets(3)
    lxlRow = 2
    rstNL.MoveFirst
    Do While Not rstNL.EOF
        xlSht.Cells(lxlRow, 1) = rstNL![RealTitle]
        xlSht.Cells(lxlRow, 2) = rstNL![Forename]
        xlSht.Cells(lxlRow, 3) = rstNL![Surname]
        xlSht.Cells(lxlRow, 4) = rstNL![EndDate]
        rstNL.MoveNext
    Loop
    MsgBox "New leaver(s) found. Check remaining Holidays in Excel sheet"
    rstNS.Close
End If

' Now autofit columns
'xlSht.Visible = xlSheetVisible
xlSht.Columns("A:Z").EntireColumn.AutoFit
SetStatusBar ("Saving Excel workbook " & strXLFile)
' Now save the workbook
xlWrkBk.SaveAs FileName:=strExportPath & strXLFile
xlWrkBk.Close
'Now email the workbook to the Submitter if tempvars gbEmail is true
If pblnMail Then
     Call Mail_Attachment(strEmail, strExportPath & strXLFile, strSubject, strMessage)
End If




ExitSub:
    xlApp.DisplayAlerts = True
    Set db = Nothing
    Set rstPR = Nothing
    Set rstNS = Nothing
    Set rstNL = Nothing
    Set xlSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    SetStatusBar (" ")

    
Err_Exit:
    Exit Sub
    
Err_Handler:
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume ExitSub
End Sub
 
D'OH just noticed I left another constant (ERR_START) in my procedure. I'm sure you've guessed what it is, but in the interest of completeness, it's basically a standard message stating that there was an error and to contact my department's support team (ie - me) with the following info, followed by a pair of line breaks.
 
You must log in or register to reply here.

Similar threads

S
REPORT TO EXCEL FORMAT
Replies
8
Views
260
Gasman
Gasman
Gasman
Solved Open Excel workbook, but have WorkBook_Open code run
Replies
19
Views
641
Gasman
Gasman
M
Export 2 forms to same spreadsheet
Replies
7
Views
459
mounty76
M
C
  • Question Question
Adding outlook.recipient values to an Access table
Replies
8
Views
291
Pat Hartman
P
B
  • Question Question
export and transpose problem
Replies
8
Views
544
Pat Hartman
P

Users who are viewing this thread

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