Export from Access to formatted Excel worksheet (1 Viewer)

[Snowflake68]

I have been trying for a very long time now to export data from an Access database into a formatted Excel worksheet (attached formatted sample Excel file) but nothing in Access seems to work very well. So it’s now time to ask for some help please as the information that is out there is just confusing me.

I am familiar with exporting flat file data using macros into Excel worksheets and CSV files etc and I know a little VBA so I am hoping that someone can provide a simple solution to my problem or at least give me some pointers on how best to approach it.

I have attached an Access database containing a table with the data in and the field name that I want to export into the formatted Excel worksheet. (Excel file has placeholders with these same names of where I want the data to appear).

The Excel file needs to have my company image at the top (this will always be the same image) followed by my customers information laid out as per the Excel example using the data from the Access table.

The Categories and Groups need to be presented as per the Excel sample.

I would like to click a button on the form to export the file and attach it to an email using DoCmd.SendObject. The file name needs to be named using the customer name and datetime stamped if possible. I currently do all of this at moment but Ive only managed to create and attached a standard non formatted Excel file (basically a straight copy of the table which is not good)

If someone could help I would be eternally grateful.

Thanks for your time.

 

[Isskint]

If you have multiple Customers in the access table, so which one do you export (how do you decide) to the spreadsheet? You could use automation to send the relevant values to the corresponding cells (using VBA open excel, then loop through your recordset 'sending' each item to the correct cell). You could create a seperate tab on the excel sheet and either export to there OR reverse it and link the sheet to the Access table, then use formuale to get the values into the OrderForm.

The simpler answer would be to create that report in Access (see attached)

 

[Snowflake68]

If you have multiple Customers in the access table, so which one do you export (how do you decide) to the spreadsheet? You could use automation to send the relevant values to the corresponding cells (using VBA open excel, then loop through your recordset 'sending' each item to the correct cell). You could create a seperate tab on the excel sheet and either export to there OR reverse it and link the sheet to the Access table, then use formuale to get the values into the OrderForm.

The simpler answer would be to create that report in Access (see attached)

The table in the sample database is just an example of the data. I would have a query to produce the rows that I need so that's not the issue.

I don't know how to do any of what you have suggested so if you are able to help with that I would very grateful.

Thanks for your reply.

 

[Snowflake68]

If you have multiple Customers in the access table, so which one do you export (how do you decide) to the spreadsheet? You could use automation to send the relevant values to the corresponding cells (using VBA open excel, then loop through your recordset 'sending' each item to the correct cell). You could create a seperate tab on the excel sheet and either export to there OR reverse it and link the sheet to the Access table, then use formuale to get the values into the OrderForm.

The simpler answer would be to create that report in Access (see attached)

Thanks for the sample report. I really need the report in Excel so that the customer can amend it so Im still at a loss of how to go about this.

 

[stopher]

Here's some code. Make sure you reference the Excel object library. Also note the file locations and file names in this code and change accordingly. Put the template in the location.

Public Sub createXLorder(ListReference As String)
    Dim xlApp As New Excel.Application
    Dim xlWrkBk As Excel.Workbook
    Dim xlSht As Excel.Worksheet
    Dim db As Database
    Dim rs As DAO.Recordset
    
    'open and reference an instance of the Excel app
    Set xlApp = CreateObject("Excel.Application")
    
    'open and reference the template file
    Set xlWrkBk = xlApp.Workbooks.Open("c:\temp\orderTemplate.xls")

    'reference the first sheet in the file
    Set xlSht = xlWrkBk.Sheets(1)
    
    'open the recordset
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT * FROM rpt_OUTPUT_ORDER where ListReference='" & ListReference & "'")
    
    If Not (rs.BOF And rs.EOF) Then
    
        'get the order header information from the first line
        rs.MoveFirst
        xlSht.Cells(3, 2) = rs.Fields("CUSTNUMBER")
        xlSht.Cells(3, 11) = rs.Fields("CustomerName")
        'etc for all the order header fields
        
        
        xlRow = 19          'set the Xl row to the first row where we want to insert detail
        curCategory = ""    'set the current category to the empty string
        curGroup = ""       'set the current group to empty string
        
        
        'loop through the recordset to get all the details
        Do While Not rs.EOF
        
            If rs.Fields("Category") <> curCategory Then                                    'start a new category
                xlRow = xlRow + 1                                                           'go to next row in spreadsheet
                xlSht.Cells(xlRow, 1) = rs.Fields("Category")                                   'write the category header
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.LineStyle = xlContinuous         'do borders
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).MergeCells = True     'merge the cells
                xlSht.Cells(xlRow, 1).Font.Size = 18                                        'set the font size for category
                xlSht.Cells(xlRow, 1).HorizontalAlignment = xlCenter                        'centre
                                    
                curCategory = rs.Fields("Category")
            End If
            
            If rs.Fields("Group") <> curGroup Then
                xlRow = xlRow + 1
                xlSht.Cells(xlRow, 1) = rs.Fields("Group")                                   'write the category header
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).MergeCells = True     'merge the cells
                xlSht.Cells(xlRow, 1).HorizontalAlignment = xlCenter
                curGroup = rs.Fields("Group")
            End If
            
            'write the detail
            xlRow = xlRow + 1
            xlSht.Cells(xlRow, 1) = rs.Fields("ItemNumber")
            'add the rest of the details here
        
            'move to the next record in the recordset
            rs.MoveNext
        Loop
        
    End If
    
    Set rs = Nothing
    Set db = Nothing
    
    xlWrkBk.saveas "c:\temp\Order_" & ListReference & ".xls"
    xlWrkBk.Close
    
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    
    MsgBox "Finished"
    

End Sub

 

[Snowflake68]

Here's some code. Make sure you reference the Excel object library. Also note the file locations and file names in this code and change accordingly. Put the template in the location.

Public Sub createXLorder(ListReference As String)
    Dim xlApp As New Excel.Application
    Dim xlWrkBk As Excel.Workbook
    Dim xlSht As Excel.Worksheet
    Dim db As Database
    Dim rs As DAO.Recordset
    
    'open and reference an instance of the Excel app
    Set xlApp = CreateObject("Excel.Application")
    
    'open and reference the template file
    Set xlWrkBk = xlApp.Workbooks.Open("c:\temp\orderTemplate.xls")

    'reference the first sheet in the file
    Set xlSht = xlWrkBk.Sheets(1)
    
    'open the recordset
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT * FROM rpt_OUTPUT_ORDER where ListReference='" & ListReference & "'")
    
    If Not (rs.BOF And rs.EOF) Then
    
        'get the order header information from the first line
        rs.MoveFirst
        xlSht.Cells(3, 2) = rs.Fields("CUSTNUMBER")
        xlSht.Cells(3, 11) = rs.Fields("CustomerName")
        'etc for all the order header fields
        
        
        xlRow = 19          'set the Xl row to the first row where we want to insert detail
        curCategory = ""    'set the current category to the empty string
        curGroup = ""       'set the current group to empty string
        
        
        'loop through the recordset to get all the details
        Do While Not rs.EOF
        
            If rs.Fields("Category") <> curCategory Then                                    'start a new category
                xlRow = xlRow + 1                                                           'go to next row in spreadsheet
                xlSht.Cells(xlRow, 1) = rs.Fields("Category")                                   'write the category header
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.LineStyle = xlContinuous         'do borders
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).MergeCells = True     'merge the cells
                xlSht.Cells(xlRow, 1).Font.Size = 18                                        'set the font size for category
                xlSht.Cells(xlRow, 1).HorizontalAlignment = xlCenter                        'centre
                                    
                curCategory = rs.Fields("Category")
            End If
            
            If rs.Fields("Group") <> curGroup Then
                xlRow = xlRow + 1
                xlSht.Cells(xlRow, 1) = rs.Fields("Group")                                   'write the category header
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).MergeCells = True     'merge the cells
                xlSht.Cells(xlRow, 1).HorizontalAlignment = xlCenter
                curGroup = rs.Fields("Group")
            End If
            
            'write the detail
            xlRow = xlRow + 1
            xlSht.Cells(xlRow, 1) = rs.Fields("ItemNumber")
            'add the rest of the details here
        
            'move to the next record in the recordset
            rs.MoveNext
        Loop
        
    End If
    
    Set rs = Nothing
    Set db = Nothing
    
    xlWrkBk.saveas "c:\temp\Order_" & ListReference & ".xls"
    xlWrkBk.Close
    
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    
    MsgBox "Finished"
    

End Sub

Thanks stopher
Forgive me but I have no idea what to do with this code nor how to reference any object library. Would you be able to advise me further please?

I have placed the order template in the Temp directory on the C drive but I dont know what to do after that.

 

[Snowflake68]

Ah Ive just found out how to reference the Excel Object library so I have done that and then ran the code which has successfully produced the order however it hasnt populated it with all of the information. See attached. Can you advise if I have done something wrong please?

View attachment Order_BXR1607151.xls

 

[Snowflake68]

Apologies stopher, Im not having a good start to the day and it would seem that I am being really lazy and not even trying to read the code (and your comments). I have so much going on at work and I was really excited that someone was helping me. I will take this away now and try to get it all to work myself.
I really appreciate your help, so a big THANK YOU for taking the time out to write this code for me.

 

[stopher]

Yes, just add more lines for each field you want. I was too lazy to do them all but just wanted to give you the principle.

Well done for figuring it out. Just shout if you need more info.

 

[Minty]

Excuse the thread hijack, but I was trying to apply a grouping subtotal to a spreadsheet from Access after some other rudimentary formatting and I cannot get it to work.

I get an error at the line in red.
Run Time Error '1004'
Subtotal method of Range class failed

 Dim xlApp           As Object
    Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .Workbooks.Add
        .Sheets("Sheet1").Select
        'Step 5: Copy the recordset to Excel
        .ActiveSheet.Range("A2").CopyFromRecordset MyRecordset
        'Step 6: Add column heading names to the spreadsheet
        For i = 1 To MyRecordset.Fields.Count
            xlApp.ActiveSheet.Cells(1, i).Value = MyRecordset.Fields(i - 1).Name
        Next i
        .Range("A1:I1").Select
        .Selection.Font.Size = 12
        With .Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            '.ThemeColor = vbRed
            .TintAndShade = -0.249977111117893
            .PatternTintAndShade = 0
        End With
        .Columns("H:H").Select
        .Selection.Style = "Currency"
        .Columns("D:E").Select
        .Selection.NumberFormat = "d/m/yyyy h:mm"
        .Cells.EntireColumn.AutoFit
        .Range("A1").Select
       [COLOR="Red"] .Cells(1, 2).CurrentRegion.SubTotal GroupBy:=1, Function:=4157, TotalList:=Array(7, 8), Replace:=True, PageBreaks:=False, [/COLOR]SummaryBelowData:=True
    End With
                                        ' xlSum constant = 4157

My Excel skills are weak I'm afraid Master Stopher...

 

[Snowflake68]

Yes, just add more lines for each field you want. I was too lazy to do them all but just wanted to give you the principle.

Well done for figuring it out. Just shout if you need more info.

Pretty much got it working now. I've even added some more formatting with borders, font size and colours. The issue I'm having now though is the Compatibility Checker message, which will be a pain for the end user if it keeps on popping up.


The other thing I have to try and sort out is how to attach the Excel file to an email to send from a click of a button in Access. Going to look at this next.

Thanks again for all you help

Below is the updated code (so far)

Option Compare Database

Public Sub test()
    
    Call createXLorder("BXR1607151")

End Sub

Public Sub createXLorder(ListReference As String)
    Dim xlApp As New Excel.Application
    Dim xlWrkBk As Excel.Workbook
    Dim xlSht As Excel.Worksheet
    Dim db As Database
    Dim rs As DAO.Recordset
    
    'open and reference an instance of the Excel app
    Set xlApp = CreateObject("Excel.Application")
    
    'open and reference the template file
    Set xlWrkBk = xlApp.Workbooks.Open("C:\Software\DE_Data\Template\OrderTemplate.xls")

    'reference the first sheet in the file
    Set xlSht = xlWrkBk.Sheets(1)
    
    'open the recordset
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT * FROM rpt_OUTPUT_ORDER where ListReference='" & ListReference & "'")
    
    If Not (rs.BOF And rs.EOF) Then
    
        'get the order header information from the first line
        rs.MoveFirst
        xlSht.Cells(3, 2) = rs.Fields("CUSTNUMBER")
        xlSht.Cells(5, 2) = rs.Fields("ADDRESS")
        xlSht.Cells(7, 2) = rs.Fields("Address2")
        xlSht.Cells(9, 2) = rs.Fields("City")
        xlSht.Cells(13, 2) = rs.Fields("Post_Code")
        
        xlSht.Cells(3, 11) = rs.Fields("CustomerName")
        xlSht.Cells(5, 11) = rs.Fields("AccNumber")
        xlSht.Cells(7, 11) = rs.Fields("SalesRep")
        'xlSht.Cells(9, 11) = rs.Fields("ContactNumber")
        'xlSht.Cells(11, 11) = rs.Fields("Email")
        xlSht.Cells(13, 11) = rs.Fields("OrderDate")
        'xlSht.Cells(15, 11) = rs.Fields("ReqDelDate")
        xlSht.Cells(17, 11) = rs.Fields("ListReference")
                
        xlRow = 19          'set the Xl row to the first row where we want to insert detail
        curCategory = ""    'set the current category to the empty string
        curGroup = ""       'set the current group to empty string
                
        'loop through the recordset to get all the details
        Do While Not rs.EOF
        
            If rs.Fields("Category") <> curCategory Then                                    'start a new category
                xlRow = xlRow + 1                                                           'go to next row in spreadsheet
                xlSht.Cells(xlRow, 1) = rs.Fields("Category")                               'write the category header
                
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.LineStyle = xlContinuous         'do borders
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.Weight = xlThin
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.Color = RGB(211, 211, 211)
                
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).MergeCells = True    'merge the cells
                xlSht.Cells(xlRow, 1).Font.Size = 14                                            'set the font size for category
                xlSht.Cells(xlRow, 1).Font.Bold = True                                          'set the font BOLD for category
                xlSht.Cells(xlRow, 1).HorizontalAlignment = xlCenter                            'centre
                                    
                curCategory = rs.Fields("Category")
            End If
            
            If rs.Fields("Group") <> curGroup Then
                xlRow = xlRow + 1
                xlSht.Cells(xlRow, 1) = rs.Fields("Group")
                'write the category header
                
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).MergeCells = True    'merge the cells
                xlSht.Cells(xlRow, 1).Font.Size = 12                                            'set the font size for Group
                xlSht.Cells(xlRow, 1).Font.Bold = True                                          'set the font BOLD for Group
                xlSht.Cells(xlRow, 1).HorizontalAlignment = xlCenter                            'centre
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.LineStyle = xlContinuous         'do borders
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.Weight = xlThin
                xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 12)).Borders.Color = RGB(211, 211, 211)
                
                curGroup = rs.Fields("Group")
            End If
            
            'write the detail
            xlRow = xlRow + 1
                    
            xlSht.Cells(xlRow, 1) = rs.Fields("ItemNumber")
            xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 2)).MergeCells = True
            xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 2)).Borders.LineStyle = xlContinuous
            xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 2)).Borders.Weight = xlThin
            xlSht.Range(xlSht.Cells(xlRow, 1), xlSht.Cells(xlRow, 2)).Borders.Color = RGB(211, 211, 211)
            
            xlSht.Cells(xlRow, 3) = rs.Fields("QTY (Cases)")
            xlSht.Cells(xlRow, 3).Borders.LineStyle = xlContinuous
            xlSht.Cells(xlRow, 3).Borders.Weight = xlThin
            xlSht.Cells(xlRow, 3).Borders.Color = RGB(211, 211, 211)
            xlSht.Cells(xlRow, 3).EntireColumn.AutoFit
            
            xlSht.Cells(xlRow, 4) = rs.Fields("CaseSize")
            xlSht.Cells(xlRow, 4).Borders.LineStyle = xlContinuous
            xlSht.Cells(xlRow, 4).Borders.Weight = xlThin
            xlSht.Cells(xlRow, 4).Borders.Color = RGB(211, 211, 211)
            xlSht.Cells(xlRow, 4).EntireColumn.AutoFit
            
            xlSht.Cells(xlRow, 5).Interior.Color = RGB(174, 240, 194)
            xlSht.Cells(xlRow, 5).Borders.LineStyle = xlContinuous
            xlSht.Cells(xlRow, 5).Borders.Weight = xlThin
            xlSht.Cells(xlRow, 5).Borders.Color = RGB(211, 211, 211)
                       
            xlSht.Cells(xlRow, 6) = "BT"
            xlSht.Cells(xlRow, 6).Borders.LineStyle = xlContinuous
            xlSht.Cells(xlRow, 6).Borders.Weight = xlThin
            xlSht.Cells(xlRow, 6).Borders.Color = RGB(211, 211, 211)
            
            xlSht.Cells(xlRow, 7) = rs.Fields("ItemDescription")
            xlSht.Range(xlSht.Cells(xlRow, 7), xlSht.Cells(xlRow, 12)).MergeCells = True
            xlSht.Range(xlSht.Cells(xlRow, 7), xlSht.Cells(xlRow, 12)).Borders.LineStyle = xlContinuous
            xlSht.Range(xlSht.Cells(xlRow, 7), xlSht.Cells(xlRow, 12)).Borders.Weight = xlThin
            xlSht.Range(xlSht.Cells(xlRow, 7), xlSht.Cells(xlRow, 12)).Borders.Color = RGB(211, 211, 211)
                            
            'move to the next record in the recordset
            rs.MoveNext
        Loop
        
    End If
    
    
    Set rs = Nothing
    Set db = Nothing
    
    xlWrkBk.saveas "C:\Software\DE_Data\Outputs\Order_" & ListReference & ".xls"
    xlWrkBk.Close
    
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
    
    MsgBox "Finished"
    

End Sub

 

[stopher]

Take a look at the saveas line. It is saving as an xls file currently. You can add a parameter to save as the file format consistent with your formatting

https://msdn.microsoft.com/en-us/library/office/ff841185.aspx

 

[Snowflake68]

Take a look at the saveas line. It is saving as an xls file currently. You can add a parameter to save as the file format consistent with your formatting

https://msdn.microsoft.com/en-us/library/office/ff841185.aspx

Thanks Stopher. I just needed to change the file extension to .xlsx and I no longer receive the compatibility message now.

Are you able to help me now with sending the Excel file in an email. I was thinking that instead of saving the file on the C drive that I could write code that attaches it to an email. Would you be able to help with writing the code as I have been looking online for help and can only find out how to send an object that is within Access.

 

[stopher]

Take a look here.

 

[Snowflake68]

Take a look here.

Apologies, not sure whether to continue to use this post to comment on or the one you pointed me at for sending attachments in an email.

Your Send Email code is brilliant though and works very well. Now I need to merge this code with the code that produces the Formatted excel file (which should be pretty straight forward) BUT how would I go about dynamically creating the file path to point at a different file each time a new order number is produced? (The file name needs to contain the order number (and I will probably add the date to it as well.)

 

[Minty]

Assign your new path & filename to a variable then simply reuse that variable to both save the excel file and then attach it to the email.

 

[Snowflake68]

Assign your new path & filename to a variable then simply reuse that variable to both save the excel file and then attach it to the email.

Doh! of course :banghead: Ill give this a go and let you know how I get on. Thanks for a quick response. You have been extremely helpful to a damsel in distress (AGAIN )

 

[stopher]

Apologies, not sure whether to continue to use this post to comment on or the one you pointed me at for sending attachments in an email.

For a new topic or problem I would generally recommend starting a new thread. I suspect new threads will get more people looking and helping for threads with no replies.

 

[stopher]

Excuse the thread hijack, but I was trying to apply a grouping subtotal to a spreadsheet from Access after some other rudimentary formatting and I cannot get it to work.

I get an error at the line in red.
Run Time Error '1004'
Subtotal method of Range class failed

 Dim xlApp           As Object
    Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .Workbooks.Add
        .Sheets("Sheet1").Select
        'Step 5: Copy the recordset to Excel
        .ActiveSheet.Range("A2").CopyFromRecordset MyRecordset
        'Step 6: Add column heading names to the spreadsheet
        For i = 1 To MyRecordset.Fields.Count
            xlApp.ActiveSheet.Cells(1, i).Value = MyRecordset.Fields(i - 1).Name
        Next i
        .Range("A1:I1").Select
        .Selection.Font.Size = 12
        With .Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            '.ThemeColor = vbRed
            .TintAndShade = -0.249977111117893
            .PatternTintAndShade = 0
        End With
        .Columns("H:H").Select
        .Selection.Style = "Currency"
        .Columns("D:E").Select
        .Selection.NumberFormat = "d/m/yyyy h:mm"
        .Cells.EntireColumn.AutoFit
        .Range("A1").Select
       [COLOR="Red"] .Cells(1, 2).CurrentRegion.SubTotal GroupBy:=1, Function:=4157, TotalList:=Array(7, 8), Replace:=True, PageBreaks:=False, [/COLOR]SummaryBelowData:=True
    End With
                                        ' xlSum constant = 4157

My Excel skills are weak I'm afraid Master Stopher...

Of hand I don't know. I'm not very familiar with sub totals in Excel let alone the object model for them. Suggest you start a new thread if you haven't already.

 

[Minty]

Will start a new thread - it's not an urgent requirement at a the moment. Thanks for looking.