Export directly to Excel from Access using VBA

Excel has a lot of tendencies that make it a less-than-desirable tool for data conversion. Too often data is corrupted by Excel's tendency to convert numbers from one international standard to another, to convert long numeric values to scientific notation and to convert dates from one format to another. The insufferable habit of trimming off leading zeros makes Excel near worthless for handling many types of SAP data.

Where Excel shines is in it's ability to act as an easy-to-use reporting tool. Handing off reports for the purposes of validation and reconciliation is best done in Excel because few functional resources are equipped to handle raw text. Additionally, Excel is the industry standard for perusing table data and is installed on almost all work computers.

Avoiding manual steps

Adding the steps to produce the validation reports to the end of an Access macro is a great way to ensure that they are produced consistently as part of the transformation of data during each phase of a project. This reduces the effort involved and eliminates manual steps that might cause inconsistencies in the data.

This function allows for multiple worksheets to be added one after another to a spreadsheet. Each worksheet gets its own name and is added to the front of the list as it is created. When a spreadsheet already has a worksheet with the same name as the worksheet to be created, the existing worksheet is deleted prior to creating the new worksheet. When the filename represents a spreadsheet that doesn't exist a new spreadsheet is created.

The function relies on two supplementary functions; the first calculates the name of a cell in the spreadsheet based on the x and y coordinates and the second determines if a value is numeric. Numeric values are preceded with a single quote so that they are stored as text in the spreadsheet and not as numbers that might be corrupted.

Note! This function has a dependency on the Excel Object Library. Add it in the module by clicking on Tools-->References and then putting a check in the box next to the Microsoft Excel Object Library.

Function ExportToExcel(strTableName, strFileName, Optional strTabName As String = "Sheet1") As Boolean

    Dim objExcel As Excel.Application
    Set objExcel = CreateObject("Excel.Application")
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet, ws2 As Excel.Worksheet
    Dim nCurrent As Long, isFound As Boolean

    On Error Resume Next
    isFound = False
    If Len(Dir(strFileName, vbNormal)) > 0 Then 'File exists!
        Set wb = objExcel.Workbooks.Open(strFileName, False, False)
        nCurrent = wb.Worksheets.Count
        Do While nCurrent > 0
            If wb.Worksheets(nCurrent).Name = strTabName Then
                objExcel.DisplayAlerts = False
                Set ws2 = wb.Worksheets(nCurrent)
                Set ws = wb.Worksheets.Add
                ws2.Delete
                ws.Name = strTabName
                isFound = True
            End If
            nCurrent = nCurrent - 1
        Loop
        If Not isFound Then
            Set ws = wb.Worksheets.Add
            ws.Name = strTabName
        End If
    Else
        Set wb = objExcel.Workbooks.Add
        wb.Worksheets(3).Delete
        wb.Worksheets(2).Delete
        wb.Worksheets(1).Name = strTabName
        Set ws = wb.Worksheets(1)
    End If
        
    Dim rs As DAO.Recordset
    Dim nFieldCount As Long, nRecordCount As Long
    Dim RetVal As Variant, nCurRec As Long, dnow As Date, nCurSec As Long
    Dim nTotalSeconds As Long, nSecondsLeft As Long
    Dim strTest As String
    
    Set rs = CurrentDb.OpenRecordset("select * from " & strTableName)
    nFieldCount = rs.Fields.Count
    
    If Not rs.EOF Then
        rs.MoveLast
        nRecordCount = rs.RecordCount
        rs.MoveFirst
    End If
    
    RetVal = SysCmd(acSysCmdInitMeter, "Exporting " & strTableName & " to " & strFileName & ". . .", nRecordCount)

    
    For nCurrent = 0 To nFieldCount - 1
        strTest = rs.Fields(nCurrent).Name
        Do While InStr(strTest, "/") > 0
            strTest = Replace(strTest, "/", "")
        Loop
        ws.Range(FindExcelCell(nCurrent + 1, 1)) = strTest
        ws.Range(FindExcelCell(nCurrent + 1, 1)).Font.Bold = True
        ws.Range(FindExcelCell(nCurrent + 1, 1)).Interior.Color = RGB(222, 222, 222)
    Next
    
    nCurSec = Second(Now())
    Do While nCurSec = Second(Now())
    Loop
    nCurSec = Second(Now())
    Do While Not rs.EOF
        nCurRec = nCurRec + 1
        If Second(Now()) <> nCurSec And nCurRec < nRecordCount Then
            nCurSec = Second(Now())
            nTotalSeconds = nTotalSeconds + 1
            If nTotalSeconds > 3 Then
                nSecondsLeft = Int(((nTotalSeconds / nCurRec) * nRecordCount) * ((nRecordCount - nCurRec) / nRecordCount))
                RetVal = SysCmd(acSysCmdRemoveMeter)
                RetVal = SysCmd(acSysCmdInitMeter, "Exporting " & strTableName & " to tab " & strTabName & " in " & strFileName & ". . .  " & nSecondsLeft & " seconds remaining.", rs.RecordCount())
                RetVal = SysCmd(acSysCmdUpdateMeter, nCurRec)
                RetVal = DoEvents()
            End If
        End If
        strTest = ""
        'Check for blank lines--no need to export those!
        For nCurrent = 0 To nFieldCount - 1
            strTest = strTest & IIf(IsNull(rs.Fields), "", rs.Fields(nCurrent).Value)
        Next
        If Len(Trim(strTest)) > 0 Then
            For nCurrent = 0 To nFieldCount - 1
                If Not IsNull(rs.Fields(nCurrent).Value) Then
                    If rs.Fields(nCurrent).Value <> "" Then
                        If IsNumeric(rs.Fields(nCurrent).Value & "") Then
                            ws.Range(FindExcelCell(nCurrent + 1, nCurRec + 1)) = "'" & Trim(rs.Fields(nCurrent).Value)
                        Else
                            ws.Range(FindExcelCell(nCurrent + 1, nCurRec + 1)) = Trim(rs.Fields(nCurrent).Value)
                        End If
                    End If
                End If
            Next
        End If
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing
    
    ws.Range("A1").Select  'Move the cursor to the very first field
    If Len(Dir(strFileName, vbNormal)) > 0 Then
        'File already exists, just close and save.
        wb.Close (True)
    Else
        'File must be created.  Save and then close without saving.
        objExcel.Workbooks(1).SaveAs (strFileName)
        objExcel.Workbooks(1).Close (False)
    End If
    objExcel.DisplayAlerts = True
    objExcel.Quit
    Set objExcel = Nothing
    
    ExportToExcel = True
    RetVal = SysCmd(acSysCmdRemoveMeter)
End Function

Function IsNumeric(strCheck As String) As Boolean
    Dim nCurrent As Long
    IsNumeric = True
    nCurrent = 0
    strCheck = Trim(strCheck)
    Do While nCurrent < Len(strCheck) And IsNumeric = True
        nCurrent = nCurrent + 1
        If InStr("01234567890", Mid(strCheck, nCurrent, 1)) < 1 Then
            IsNumeric = False 'Part of the string is not a digit!
        End If
    Loop
End Function

Function FindExcelCell(nX As Long, nY As Long) As String
    Dim nPower1 As Long, nPower2 As Long
    nPower2 = 0
    If nX > 26 Then
        nPower2 = Int((nX - 1) / 26)
    End If
    nPower1 = nX - (26 * nPower2)
    If nPower2 > 0 Then
        FindExcelCell = Chr(64 + nPower2) & Chr(64 + nPower1) & nY
    Else
        FindExcelCell = Chr(64 + nPower1) & nY
    End If
End Function