Make Excel Sheets From Access Table

Excel Sheets From Access Table

OP “avalve” asked this question on Access World Forums:- “Howdy! Let me make a small scenario. Let’s say I have a table with fields CarMake/CarModel/Year/Color. What I am trying to do is to export the table to a single Excel Workbook with each CarMake having their own page displaying only their results”.

I don’t have much experience when it comes to manipulating Excel from MS Access, it’s an area I need some improvement! So I thought well here’s a challenge! I also had a bit of a leg up because I recently found some excellent code for manipulating Excel from MS Access and realised it would be a good basis in which to undertake answering this question.

…         ..         ..            ..        ..          ..           ..     ..  ..         … 

Export Query into Seperate Excel Sheets

Export Query into Seperate Excel Sheets

Video 1 (01:41)

With this sample database from Nifty Access I demonstrate how you can take different sets of records from an MS Access table and show each different set on a separate spreadsheet page in Excel. The file is:- Export Query into Separate Excel Sheets – Nifty Access

Video 1 (01:41)

Play Video

… …

Query to Excel Sheets - Hows It Done?

Query to Excel Sheets - Hows It Done?

Video 2 (8:04)

How’s it done? In this video I go through the code, pointing out some of it’s features. I demonstrate how to create the SQL Statements necessary to get the code to run. If this is of interest, then below you will see the code. Just paste it into a Form, create the relevant SQL in the query designer grid and place that in the relevant place in the code, and away you go. If you’re not o fey with VBA coding, then I have a drop-in component, just copy the Form into your database, select the table, select the field you want to become sheet names in Excel, and away you go! The Drop-in Version can be downloaded HERE:-

Video 2 (8:04)

Play Video

… …

Free Code Version Here

Copy the block of code below and place in a Form. Place a Command Button named:- “btnRunMoveToXL” on the Form to call the Code. Get the DataSet, (the Table of vehicles) from the link provided. https://www.ebay.co.uk/pages/help/sell/contextual/master-vehicle-list-manually.html If you have any problems, then post your questions in Access World Forums (AWF) in this thread:- https://www.access-programmers.co.uk/forums/showthread.php?t=303587 alternatively there is a paid-for version which is hosted on Sellfy.

Option Compare Database
Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'>>> Database by Tony Hine, alias Uncle Gizmo                                                  <<<
'>>> Created Feb, 2019                                                                         <<<
'>>> Last up-dated Feb, 2019                                                                   <<<
'>>> Telephone International: +44 7747 018 875                                                 <<<
'>>> Telephone UK: 07747 018 875                                                               <<<
'>>> e-mail: [email protected]                                                           <<<
'>>> Skype: unclegizmo (I seldom Use Skype)                                                    <<<
'>>> I post at the following forum (mostly) :                                                  <<<
'>>> http://www.access-programmers.co.uk/forums/  (alias Uncle Gizmo)                          <<<
'>>> If my e-mail don't work, try this website: http://www.tonyhine.co.uk/example_help.htm     <<<
'>>> This is my public playground Website for MS Access:-                                      <<<
'>>> The Nifty Access Website is sales orientated:-                                            <<<
'>>> www.niftyaccess.com (A vehicle for me to generate an income from my retirement)           <<<
'>>> My YouTube Channel HERE:- https://www.youtube.com/user/UncleGizmo                         <<<
'>>> CODE SUPPLIED NOT CHECKED AND TESTED FOR ERRORS!!!! Be Warned                             <<<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

'OP Question Here:- https://www.access-programmers.co.uk/forums/showthread.php?t=303587
'Adapted by Uncle Gizmo - From:- https://btabdevelopment.com/export-a-table-or-query-to-excel/
'Vehicle DataSet found at:- https://www.ebay.co.uk/pages/help/sell/contextual/master-vehicle-list-manually.html

'Other Usful Tips
'https://wellsr.com/vba/2016/excel/4-useful-vba-delete-worksheet-macro-examples/

Private Sub btnRunMoveToXL_Click()
'Add a Button to your form to Call this

    Call fRSL_XL_SheetsFromTbl

End Sub      'btnRunMoveToXL_Click

Private Sub fRSL_XL_SheetsFromTbl()
'RSL = Record Set Loop
Dim strSubName As String
Dim strModuleName As String

strSubName = "fRSL_XL_SheetsFromTbl"
strModuleName = "Form - " & Me.Name

On Error GoTo Error_Handler
    
    Dim curDB As DAO.Database
    Dim rst1 As DAO.Recordset
    Dim rst2 As DAO.Recordset
    
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    
    'Dim lngTable As Long
    Dim strCarMake As String
    Dim strSQL_RSL As String
    
    Set curDB = CurrentDb

strSQL_RSL = "SELECT DISTINCT Make1 FROM tblCars"

    Set rst1 = curDB.OpenRecordset(strSQL_RSL, dbOpenForwardOnly)
       
        Set ApXL = CreateObject("Excel.Application")
        Set xlWBk = ApXL.Workbooks.Add
        ApXL.Visible = True
       
            Do Until rst1.EOF
                strCarMake = rst1!Make1
                    Set rst2 = CurrentDb.OpenRecordset(fSQL_FillSheetWith(strCarMake))
                    
                    'Add Extra Worksheet by moving over 1 on each iteration
                        Set xlWSh = xlWBk.sheets.Add(After:=xlWBk.Worksheets(xlWBk.Worksheets.Count))
                            xlWSh.Name = strCarMake
                            
                                xlWSh.Activate
                                xlWSh.Range("A1").Select
                                
                                    'Get the Headings from the Recordset
                                    For Each fld In rst2.Fields
                                        ApXL.ActiveCell = fld.Name
                                        ApXL.ActiveCell.Offset(0, 1).Select
                                    Next
                    
                            rst2.MoveFirst
                            xlWSh.Range("A2").CopyFromRecordset rst2
                            xlWSh.Range("1:1").Select
                        
                    ' selects all of the cells
                    ApXL.ActiveSheet.Cells.Select
                    ' does the "autofit" for all columns
                    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
                    ' selects the first cell to unselect all cells
                    xlWSh.Range("A1").Select

                rst1.MoveNext
            Loop
            
        'Remove the auto generated Sheet Sheet1
        For Each xlWSh In xlWBk.Worksheets
             If xlWSh.Name = "Sheet1" Then
                  xlWSh.Delete
             End If
        Next xlWSh
    
Exit_ErrorHandler:

        rst1.Close
    Set rst1 = Nothing

        rst2.Close
    Set rst2 = Nothing

    Set curDB = Nothing
    
    Exit Sub

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
        
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
            
            Select Case Err.Number
                 Case -2147417848 'The object invoked has disconnected from its clients. .
                    MsgBox "This error can occur if you close the Excel spreadsheet before the code finishes." & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                 Case 3265 'Item not found in this collection.
                    MsgBox "This Error is usually caused when your Record Set Loop (RSL) has the wrong name for one of the fields in the table." & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo
            End Select
        Resume Exit_ErrorHandler

End Sub     'fRSL_XL_SheetsFromTbl

Private Function fSQL_FillSheetWith(ByVal strCarMake As String) As String
Dim strSubName As String
Dim strModuleName As String

Dim conAppName As String
conAppName = "(Replace this Local Variable with a Global One) "

strSubName = "fSQL_FillSheetWith"
strModuleName = "Form - " & Me.Name

On Error GoTo Error_Handler

Dim strSQL0 As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String
Dim strSQL4 As String

'MsgBox " >>> " & strCarMake

''Format Text Correctly for the SQL Statement
strCarMake = Chr(34) & strCarMake & Chr(34) '"

'MsgBox " >>> " & strCarMake

'SELECT ID, Make1, Model1, Variant1, BodyStyle1, Type1, Year1, Engine1, [K-Type]
'FROM tblCars
'WHERE (((Make1)=
'"BMW"
'));

'Import this DataSet:-
'Vehicle Dataset found at:- https://www.ebay.co.uk/pages/help/sell/contextual/master-vehicle-list-manually.html
'in to a Table named "tblCars in your MS Access Database"
'Make sure the table has these field Headings:- ID, Make1, Model1, Variant1, BodyStyle1, Type1, Year1, Engine1, [K-Type]

strSQL1 = "SELECT ID, Make1, Model1, Variant1, BodyStyle1, Type1, Year1, Engine1, [K-Type] "
strSQL2 = "FROM tblCars "
strSQL3 = "WHERE (((Make1)="
'"BMW"
strSQL4 = "));"


strSQL0 = strSQL1 & strSQL2 & strSQL3 & strCarMake & strSQL4

fSQL_FillSheetWith = strSQL0

Exit_ErrorHandler:
    
    Exit Function

Error_Handler:
    Dim strErrFrom As String
    Dim strErrInfo As String
        
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
            
            Select Case Err.Number
                Case 0.123 'When Required, Replace Place Holder (1) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
            End Select
        Resume Exit_ErrorHandler

End Function      'fSQL_FillSheetWith