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 Separate Excel Sheets

Export Query into Separate 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)

Nifty Access YouTube Thumb Nail
Play Video

… …

Export 45000 Rows to 286 Sheets

Export 45000 Rows to 286 Sheets

Video 2 (2:08)

This is really COOL!

Watch this Code (Available Below) import 45000 records from an MS Access database into an Excel spreadsheet. Not a straightforward import, as the import routine places individual groups of DATA in individual sheets! The MS Access table contains around 45000 rows of data relating to individual car Models. Each model is in a “Make” Group, and there are 286 Makes. Each individual Excel sheet created represent a “Make of Car” and there are “286 Makes of Cars”. Therefore the import routine creates 286 spreadsheet pages! Watch the video it’s impressive!

Video 2 (2:08)

Nifty Access YouTube Thumb Nail
Play Video

… …

Query to Excel Sheets - Hows It Done?

Query to Excel Sheets - Hows It Done?

Video 3 (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 3 (8:04)

Nifty Access YouTube Thumb Nail
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

(please note eBay’s conditions on using this data)

The “Master Vehicle List” is in text format… (without an ID field). You need to ADD the ID as an AutoNumber field.

Using the big data set of 45000 vehicles I discovered a bug. The code failed when it got to “Ford” because the next car name “Ford Asia/Oceania” (Used for the Excel Sheet Name) contained a special character, in particular “/”… To fix this issue I added another function “fStripIllegal” This function removes the non-standard characters from a text string.

Incidentally, if you read Minty’s comments you will find that he uses this function himself for exactly the same use I put it to, namely to correctly format VBA created sheet names in Excel…

Steps to Create this Yourself

  • Download the eBay vehicle list (Excel File)
  • Import the Vehicle List into MS Access
  • Add an auto number field to it
  • Name the auto number field “ID”
  • Name the rest of the fields as indicated in the video
  • Create a Form with the command button “btnRunMoveToXL”

I think that’s about it if I’ve missed anything just check the video and let me know and I will fix it!

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 a Digital Downloads Site.

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 for 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/
'https://www.access-programmers.co.uk/forums/threads/code-to-replace-special-character-with-space.278238/#post-1701099


'*******************************************************************************************************
'*******************************************************************************************************
'*******************************************************************************************************

'############## ---------------- Control Events ---------------------- ########
Private Sub btnRunMoveToXL_Click()
'Add a Button to your form to Call this

    Call fRSL_XL_SheetsFromTbl

End Sub      'btnRunMoveToXL_Click

'############## ---------------- Primary Routines -------------------- ########
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))
                            
                            'Update 2020_06_10 to Remove Illegal Characters From Excel Sheet Name
                            'Note:- http://www.excelcodex.com/2012/06/worksheets-naming-conventions/
                            xlWSh.Name = fStripIllegal(strCarMake)
                            
                                xlWSh.Activate
                                xlWSh.Range("A1").Select
                                
                                    'Get the Headings from the Recordset
                                    For Each fld In rst2.Fields
                                    'Update to Remove Illegal Characters From Excel Sheet Name
                                        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 3061 'Too few parameters. Expected 1.
                    MsgBox "This error occurred when the ID field was set to short text instead of AutoNumber." & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                Case 91 'Object variable or With block variable not set.
                    MsgBox "Lots of things can cause this error. In this Routine it occurred when the ID field was set to short text instead of AutoNumber." & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                Case 424 'Object required.
                    MsgBox "This error can occur if you close the Excel spreadsheet before the code finishes." & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo
            End Select
        Resume Exit_ErrorHandler

End Sub     'fRSL_XL_SheetsFromTbl

'############## ---------------- SQL Statements ---------------------- ########
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]
'Make sure the ID field Data Type is AutoNumber and the rest are Short Text:-
'ID As AutoNumber
'Make1, Model1, Variant1, BodyStyle1, Type1, Year1, Engine1, [K-Type] as Short Test

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

'############## ---------------- Helper Routines --------------------- ########
Function fStripIllegal(strCheck As String, Optional strReplaceWith As String = "") As String
'https://www.access-programmers.co.uk/forums/threads/code-to-replace-special-character-with-space.278238/
    On Error GoTo StripIllErr
    'illegal file name characters included in default string are    ? [ ] /  = + < > :; * " , '

    Dim intI As Integer
    Dim intPassedString As Integer
    Dim intCheckString As Integer
    Dim strChar As String
    Dim strIllegalChars As String
    Dim intReplaceLen As Integer

    If IsNull(strCheck) Then Exit Function

    strIllegalChars = "?[]/=+<>:;,*" & Chr(34) & Chr(39) & Chr(13) & Chr(10)  'add/remove characters you need removed to this string

    intPassedString = Len(strCheck)
    intCheckString = Len(strIllegalChars)

    intReplaceLen = Len(strReplaceWith)

    If intReplaceLen > 0 Then   'a character has been entered to use as the replacement character
    
        If intReplaceLen = 1 Then   'check the character itself isn't an illegal character
        
            If InStr(strIllegalChars, strReplaceWith) > 0 Then
                MsgBox "You can't replace an illegal character with another illegal character", _
                       vbOKOnly + vbExclamation, "Invalid Character"
                fStripIllegal = strCheck
                Exit Function
            End If

        Else   'only one replacement character allowed

            MsgBox "Only one character is allowed as a replacement character", _
                   vbOKOnly + vbExclamation, "Invalid Replacement String"
            fStripIllegal = strCheck
            Exit Function
            
        End If
    End If

    If intPassedString < intCheckString Then

        For intI = 1 To intCheckString
            strChar = Mid(strIllegalChars, intI, 1)
            If InStr(strCheck, strChar) > 0 Then
                strCheck = Replace(strCheck, strChar, strReplaceWith)
            End If
        Next intI

    Else

        For intI = 1 To intPassedString
            strChar = Mid(strIllegalChars, intI, 1)
            If InStr(strCheck, strChar) > 0 Then
                strCheck = Replace(strCheck, strChar, strReplaceWith)
            End If
        Next intI

    End If

    fStripIllegal = Trim(strCheck)

StripIllErrExit:
    Exit Function

StripIllErr:
    MsgBox "The following error occured: " & Err.Number & vbCrLf _
         & Err.Description, vbOKOnly + vbExclamation, "Unexpected Error"

    fStripIllegal = strCheck

    Resume StripIllErrExit

End Function      'fStripIllegal

Do you need a hand in the right direction?

You are in the right place.