. . . Database development featuring Microsoft Access

Call 512-202-7121

For Free Consultation


Advanced Access Export Function
To Excel Spreadsheet Using VBA

Multiple Access Functions Export Data To An Excel Spreadsheet

This example utilizes several advanced VBA functions to export an Access table to Excel. The user enters a file path for output, then clicks on the command button to start the Access VBA export function. If the output file already exists, the user is prompted to either overwrite the existing file or replace it. Once the export process is completed, the VBA code opens the new Excel file. There are several function calls to complete this process.

NOTE: The following code is for demonstration purposes only and is not a complete coding solution.

Export Access to Excel

If the file name and path already exist, a message pops up asking the user to continue. Note: that the name of the Excel file is embedded in the VBA code.

Excel file exists

The Button Code

Clicking on the command button calls this code . . .

Starting routine for Access to Excel export

The 3 function calls in this subroutine are:

  • MyFileExists: Returns a boolean True or False if the file already exists
  • RunExcel: Creates the Excel workbook and formats worksheet
  • OpenExcelAddWorkbook: Opens an instance of Excel to view the spreadsheet


Excel file exists


Public Function OpenExcelAddWorkbook(strFullFileName As String, _
strWorkbookName As String, _
strQueryName As String, _
Optional blnClose As Boolean) As Boolean
'Format and open Excel spreadsheet
'Creates an Excel database
'Created by Scott Walker, Accessible Data Solutions 02/8/2011

On Error GoTo Err_Proc

If Len(strFullFileName) = 0 Then
MsgBox "Missing filename.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

If Len(strWorkbookName) = 0 Then
MsgBox "Missing sheet name.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

If Len(strQueryName) = 0 Then
MsgBox "Missing query name or SQL string.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

Dim objApp As Object
Dim intSR As Integer
Dim dbs As DAO.Database
Dim rsRecords As DAO.Recordset
Dim strMsg As String
Dim lngMaxCol As Long
Dim lngMaxRow As Long
Dim i As Long
Dim strHeading As String
Dim blnWorksheetExists As Boolean
Dim blnSpreadsheetExists As Boolean

' Open database
Set dbs = CurrentDb

' Open recordset
Set rsRecords = dbs.OpenRecordset(strQueryName)

If rsRecords.EOF And rsRecords.BOF Then
MsgBox "Query or SQL returned no records.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

' Open excel and add workbook
Set objApp = CreateObject("Excel.Application")
objApp.UserControl = True

' If no physical location passed, Excel will use the users working directory
' i.e. My Documents. Therefore the test for the existance of the spreadsheet
' will fail to locate it.

blnSpreadsheetExists = MyFileExists(strFullFileName)

If blnSpreadsheetExists Then
objApp.Workbooks.Open strFullFileName
End If

' Prompts are enabled to prevent overwriting of existing spreadsheet
objApp.DisplayAlerts = True

' Test if Worksheets exists
If blnWorksheetExists = True Then
MsgBox "Workbook " & strWorkbookName & " exists!" & _
vbCrLf & vbCrLf & "Data not changed.", vbInformation + vbOKOnly, "Error"
Exit Function
objApp.ActiveWorkbook.Worksheets.Add.Name = "" & strWorkbookName & ""
End If

With objApp.Worksheets("" & strWorkbookName & "")
lngMaxCol = rsRecords.Fields.Count

If rsRecords.RecordCount > 0 Then
lngMaxRow = rsRecords.RecordCount

If lngMaxRow > 65536 Then
strMsg = Format(lngMaxRow, "#,##0") & " exceeds the maximum " & _
"of 65,536 rows that can be " & vbCrLf

If blnSpreadsheetExists Then
strMsg = strMsg & "exported directly...you will have " & _
"to manully export the " & vbCrLf & _
strMsg = strMsg & "into a spreadsheet."
MsgBox strMsg

Set rsRecords = Nothing
Set dbs = Nothing

objApp.DisplayAlerts = False
DoCmd.OpenQuery strQueryName, acViewNormal, acReadOnly

MsgBox "Now use the File + Export manual method."
Exit Function


strMsg = strMsg & "exported directly...switching to transfer."
MsgBox strMsg

Set rsRecords = Nothing
Set dbs = Nothing

objApp.DisplayAlerts = False

DoCmd.TransferSpreadsheet acExport, _ acSpreadsheetTypeExcel9, _
/> strQueryName, _
strFullFileName, True

RunExcel strFullFileName
Exit Function

End If

End If

' Let user see the data added

objApp.Visible = True
For i = 1 To lngMaxCol
.Cells(1, i).FormulaR1C1 = rsRecords.Fields(i - 1).Name
.Cells(1, i).Font.Bold = True

' ColorIndex values: 0 Auto, 1 Black, 2 White, 3 Red, 5 Blue,
'6 Yellow, 10 Green, 40 Tan, 36 Light Yellow, 35 Light Green,
'34 Light Turquoise, 37 Pale Blue

.Cells(1, i).Font.ColorIndex = 1
.Cells(1, i).Interior.ColorIndex = 35
.Cells(1, i).Interior.Pattern = 1 'Excel ref variable xlSolid = 1
.Cells(1, i).Interior.PatternColorIndex = -4105 'Excel ref variable PatternColorIndex = -4105


.Range(.Cells(2, 1), .Cells(lngMaxRow, lngMaxCol)).CopyFromRecordset rsRecords
'Excel ref variable xlLeft = -4131
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).HorizontalAlignment = -4131
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).AutoFilter
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).EntireColumn.AutoFit

End If

' Select all data
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).Select

End With

Set rsRecords = Nothing

' Save excel spreadsheet
If blnSpreadsheetExists Then
objApp.ActiveWorkbook.SaveAs strFullFileName
End If

' Reset alerts prompts
objApp.DisplayAlerts = True
Set dbs = Nothing
If blnClose Then
End If

OpenExcelAddWorkbook = True

Exit Function


If Err.Number = 9 Then
blnWorksheetExists = False
Resume Next
MsgBox Err.Number & "-" & Err.Description
Resume Exit_Proc
End If

End Function

The Excel Spreadsheet Workbook

The image below shows a portion of the Excel spreadsheet workbook that results from the code above. Note the color formatting.

Excel workbook from Access export