MS Access - VBA - Export RecordSet to Excel (2023)

Very similarly to my MS Access – VBA – Export Records to Excel post, I found myself needing to easily export a form’s recordset to Excel. Not the underlying table or query, but the filtered, currently viewed recordset. I already had the above code so I made a few very minor tweaks et voila I had a new function that could export, with ease, any recordset to Excel. Hopefully it can help someone else!

'---------------------------------------------------------------------------------------' Procedure : ExportRecordset2XLS' Author : Daniel Pineault, CARDA Consultants Inc.' Website : http://www.cardaconsultants.com' Purpose : Export the passed recordset to Excel' Copyright : The following is release as Attribution-ShareAlike 4.0 International' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/'' Input Variables:' ~~~~~~~~~~~~~~~~' rs : Recordset object to export to excel'' Usage:' ~~~~~~' Call ExportRecordset2XLS(Me.RecordsetClone)'' Revision History:' Rev Date(yyyy/mm/dd) Description' **************************************************************************************' 1 2017-Mar-13 Initial Release' 2 2018-09-20 Updated Copyright'---------------------------------------------------------------------------------------Function ExportRecordset2XLS(ByVal rs As DAO.Recordset) '#Const EarlyBind = True 'Use Early Binding, Req. Reference Library #Const EarlyBind = False 'Use Late Binding #If EarlyBind = True Then 'Early Binding Declarations Dim oExcel As Excel.Application Dim oExcelWrkBk As Excel.WorkBook Dim oExcelWrSht As Excel.WorkSheet #Else 'Late Binding Declaration/Constants Dim oExcel As Object Dim oExcelWrkBk As Object Dim oExcelWrSht As Object Const xlCenter = -4108 #End If Dim bExcelOpened As Boolean Dim iCols As Integer 'Start Excel On Error Resume Next Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one Err.Clear On Error GoTo Error_Handler Set oExcel = CreateObject("Excel.Application") bExcelOpened = False Else 'Excel was already running bExcelOpened = True End If On Error GoTo Error_Handler oExcel.ScreenUpdating = False oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook Set oExcelWrSht = oExcelWrkBk.Sheets(1) With rs If .RecordCount <> 0 Then .MoveFirst 'This is req'd, had some strange behavior in certain instances without it! 'Build our Header '**************** For iCols = 0 To rs.Fields.Count - 1 oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name Next 'Format the header With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ oExcelWrSht.Cells(1, iCols)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With 'Copy the data from our query into Excel '*************************************** oExcelWrSht.Range("A2").CopyFromRecordset rs 'Some formatting to make things pretty! '************************************** 'Freeze pane oExcelWrSht.Rows("2:2").Select With oExcel.ActiveWindow .SplitColumn = 0 .SplitRow = 1 .FreezePanes = True End With 'AutoFilter oExcelWrSht.Rows("1:1").AutoFilter 'Fit the columns to the content oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ oExcelWrSht.Cells(1, iCols)).EntireColumn.AutoFit 'Start at the top oExcelWrSht.Range("A1").Select Else MsgBox "There are no records returned by the specified queries/SQL statement.", _ vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with" GoTo Error_Handler_Exit End If End WithError_Handler_Exit: On Error Resume Next oExcel.Visible = True 'Make excel visible to the user Set rs = Nothing Set oExcelWrSht = Nothing Set oExcelWrkBk = Nothing oExcel.ScreenUpdating = True Set oExcel = Nothing Exit FunctionError_Handler: MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: ExportRecordset2XLS" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "An Error has Occurred!" Resume Error_Handler_ExitEnd Function

As you can see by examining the code it includes Conditional Compiling Directive so you can have it either as Early or Late Binding to suit your preferences.

Furthermore, the following sections of code are completely optional and are simply used to perform some basic formatting (pretty things up and make the worksheet easier to work with IMHO). I’ve left it in place should it be useful to you and also to illustrate how easily you can perform other automations at the same time as performing the export (show some of the syntax). Feel free to remove it as you see fit.

 'Format the header With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ oExcelWrSht.Cells(1, iCols)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With

and

 'Some formatting to make things pretty! '************************************** 'Freeze pane oExcelWrSht.Rows("2:2").Select With oExcel.ActiveWindow .SplitColumn = 0 .SplitRow = 1 .FreezePanes = True End With 'AutoFilter oExcelWrSht.Rows("1:1").AutoFilter 'Fit the columns to the content oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ oExcelWrSht.Cells(1, iCols)).EntireColumn.AutoFit

Taking Things Even Further :: ExportRecordset2XLS V2.0!

Now the above functions does exactly as intended, but what if we wanted more flexibility and more control over what is applied depending on the situation! This is the beauty of VBA once you truly get into it, you can develop some true coding gems that can be utilized in all sorts of situations.

So let reexamine the above function, how could we modify it to not need to actually remove sections of code depending on whether or not we want autofilters applies, or freeze panes, …? How could we make if flexible enough to even allow the user to specify an exist workbook to export to, and if none is specified then create a new one. How can we make a universal function?

Surprisingly, with a pretty small number of tweak to the above function we can do all that!

'---------------------------------------------------------------------------------------' Procedure : ExportRecordset2XLS' Author : Daniel Pineault, CARDA Consultants Inc.' Website : http://www.cardaconsultants.com' Purpose : Export the passed recordset to Excel' Copyright : The following is release as Attribution-ShareAlike 4.0 International' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/'' Input Variables:' ~~~~~~~~~~~~~~~~' rs : Recordset object to export to excel' sFile : Optional -> File path and name to update' If none is provided a new Excel file is created' sWrkSht : Optional -> Name of the Worksheet to update' If sWrkSht is supplied and the sheet does not exist it will be' created' lStartCol : Optional -> Column number to start inserting the data into' If none is supply insert will be start on the 1st Column' lStartRow : Optional -> Row number to start inserting the data into' If none is supply insert will be start on the 1st Row' bFitCols : Optional -> Auto Fit the column to the width of the data contained within' Default is True' bFreezePanes : Optional -> Freeze the Header row' Default is True' bAutoFilter : Optional -> AutoFilter the data' Default is True'' Usage:' ~~~~~~' Call ExportRecordset2XLS(Me.RecordsetClone)'' Revision History:' Rev Date(yyyy/mm/dd) Description' **************************************************************************************' 1 2017-Mar-13 Initial Release' 2 2017-Mar-16 Added sFile' Added sWrkSht' Added lStartCol' Added lStartRow' Added bFitCols' Added bFreezePanes' Added bAutoFilter' 2 2018-09-20 Updated Copyright'---------------------------------------------------------------------------------------Function ExportRecordset2XLS(ByVal rs As DAO.Recordset, _ Optional ByVal sFile As String, _ Optional ByVal sWrkSht As String, _ Optional ByVal lStartCol As Long = 1, _ Optional ByVal lStartRow As Long = 1, _ Optional bFitCols As Boolean = True, _ Optional bFreezePanes As Boolean = True, _ Optional bAutoFilter As Boolean = True) '#Const EarlyBind = True 'Use Early Binding, Req. Reference Library #Const EarlyBind = False 'Use Late Binding #If EarlyBind = True Then 'Early Binding Declarations Dim oExcel As Excel.Application Dim oExcelWrkBk As Excel.WorkBook Dim oExcelWrkSht As Excel.WorkSheet #Else 'Late Binding Declaration/Constants Dim oExcel As Object Dim oExcelWrkBk As Object Dim oExcelWrkSht As Object Const xlCenter = -4108 #End If Dim bExcelOpened As Boolean Dim iCols As Integer Dim lWrkBk As Long 'Start Excel On Error Resume Next Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one Err.Clear On Error GoTo Error_Handler Set oExcel = CreateObject("Excel.Application") bExcelOpened = False Else 'Excel was already running bExcelOpened = True End If On Error GoTo Error_Handler oExcel.ScreenUpdating = False oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation If sFile <> "" Then Set oExcelWrkBk = oExcel.Workbooks.Open(sFile) 'Start a new workbook On Error Resume Next lWrkBk = Len(oExcelWrkBk.Sheets(sWrkSht).Name) If Err.Number <> 0 Then oExcelWrkBk.Worksheets.Add.Name = sWrkSht Err.Clear End If On Error GoTo Error_Handler Set oExcelWrkSht = oExcelWrkBk.Sheets(sWrkSht) oExcelWrkSht.Activate Else Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook Set oExcelWrkSht = oExcelWrkBk.Sheets(1) If sWrkSht <> "" Then oExcelWrkSht.Name = sWrkSht End If End If With rs If .RecordCount <> 0 Then .MoveFirst 'This is req'd, had some strange behavior in certain instances without it! 'Build our Header '**************** For iCols = 0 To rs.Fields.Count - 1 oExcelWrkSht.Cells(lStartRow, lStartCol + iCols).Value = rs.Fields(iCols).Name Next 'Format the header With oExcelWrkSht.Range(oExcelWrkSht.Cells(lStartRow, lStartCol), _ oExcelWrkSht.Cells(lStartRow, lStartCol + iCols - 1)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With 'Copy the data from our query into Excel '*************************************** oExcelWrkSht.Cells(lStartRow + 1, lStartCol).CopyFromRecordset rs 'Some formatting to make things pretty! '************************************** 'Freeze pane If bFreezePanes = True Then oExcelWrkSht.Cells(lStartRow + 1, 1).Select oExcel.ActiveWindow.FreezePanes = True End If 'AutoFilter If bAutoFilter = True Then oExcelWrkSht.Rows(lStartRow & ":" & lStartRow).AutoFilter End If 'Fit the columns to the content If bFitCols = True Then oExcelWrkSht.Range(oExcelWrkSht.Cells(lStartRow, lStartCol), _ oExcelWrkSht.Cells(lStartRow, lStartCol + iCols)).EntireColumn.AutoFit End If 'Start at the top oExcelWrkSht.Cells(lStartRow, lStartCol).Select Else MsgBox "There are no records returned by the specified queries/SQL statement.", _ vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with" GoTo Error_Handler_Exit End If End WithError_Handler_Exit: On Error Resume Next oExcel.Visible = True 'Make excel visible to the user Set rs = Nothing Set oExcelWrkSht = Nothing Set oExcelWrkBk = Nothing oExcel.ScreenUpdating = True Set oExcel = Nothing Exit FunctionError_Handler: MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: ExportRecordset2XLS" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "An Error has Occurred!" Resume Error_Handler_ExitEnd Function

Download

Feel free to download a copy by using the links provided below:

Disclaimer/Notes:

The YouTube Demo File:

The Original Article File:

As requested, feel free to download a fully function sample 2003 mdb of the above code which illustrates how it can be implemented.
Export Recordset To Excel (2K3 mdb)