Exporting Access Table to Excel but change column titles

Question

I am trying to export a table to Excel. I use this code:

fileName = "My_Export_" & DateDiff("s", #1/1/1970#, Now()) & ".xlsx"
exportPath = CurrentProject.Path & "\SomeFolder\" & fileName    
DoCmd.TransferSpreadsheet acExport, 10, "myTtableName", exportPath, True

This works fine but, when it export the columns, the title for each column is usually not reader friendly (it uses typical field naming conventions). Is there a way to change the column titles to something more user friendly?

thanks

Answer 1

Create a straight select query where you specify the friendly names:

Select
    SomeField As [New Sales],
    AnotherField As [Sales District],
    SomeOtherField As [Sales Volume]
From
    myTableName

Save this and the use the name of your query when exporting:

DoCmd.TransferSpreadsheet acExport, 10, "SavedQueryName", exportPath, True

Answer 2

I use a fairly long winded way of exporting to Excel - at the moment it only exports a query or recordset object, but a simple SELECT * FROM Table1 will turn your table into a query - or the code can be updated to accept a table reference.

It does, however, allow you to specify the header text, the sheet name and the first cell to import to.

This is the code that performs the export:

'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author    : Darren Bartrup-Cook
' Date      : 26/08/2014
' Purpose   : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
                                                  Optional rst As DAO.Recordset, _
                                                  Optional SheetName As String, _
                                                  Optional rStartCell As Object, _
                                                  Optional AutoFitCols As Boolean = True, _
                                                  Optional colHeadings As Collection) As Boolean

    Dim db As DAO.Database
    Dim prm As DAO.Parameter
    Dim qdf As DAO.QueryDef
    Dim fld As DAO.Field
    Dim oXLCell As Object
    Dim vHeading As Variant

    On Error GoTo ERROR_HANDLER

    If sQueryName <> "" And rst Is Nothing Then

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Open the query recordset.                               '
        'Any parameters in the query need to be evaluated first. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Set db = CurrentDb
        Set qdf = db.QueryDefs(sQueryName)
        For Each prm In qdf.Parameters
            prm.Value = Eval(prm.Name)
        Next prm
        Set rst = qdf.OpenRecordset
    End If

    If rStartCell Is Nothing Then
        Set rStartCell = wrkSht.cells(1, 1)
    Else
        If rStartCell.Parent.Name <> wrkSht.Name Then
            Err.Raise 4000, , "Incorrect Start Cell parent."
        End If
    End If


    If Not rst.BOF And Not rst.EOF Then
        With wrkSht
            Set oXLCell = rStartCell

            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Paste the field names from the query into row 1 of the sheet. '
            'TO DO: Facility to use an alternative name.                   '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            If colHeadings Is Nothing Then
                For Each fld In rst.Fields
                    oXLCell.Value = fld.Name
                    Set oXLCell = oXLCell.Offset(, 1)
                Next fld
            Else
                For Each vHeading In colHeadings
                    oXLCell.Value = vHeading
                    Set oXLCell = oXLCell.Offset(, 1)
                Next vHeading
            End If

            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Paste the records from the query into row 2 of the sheet. '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Set oXLCell = rStartCell.Offset(1, 0)
            oXLCell.copyfromrecordset rst
            If AutoFitCols Then
                .Columns.Autofit
            End If

            If SheetName <> "" Then
                .Name = SheetName
            End If

            '''''''''''''''''''''''''''''''''''''''''''
            'TO DO: Has recordset imported correctly? '
            '''''''''''''''''''''''''''''''''''''''''''
            QueryExportToXL = True

        End With
    Else

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'There are no records to export, so the export has failed. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        QueryExportToXL = False
    End If

    Set db = Nothing

    On Error GoTo 0
    Exit Function

ERROR_HANDLER:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure QueryExportToXL."
            Err.Clear
            Resume
    End Select

End Function

This code is required to create a new Excel workbook in my example (although you can just pass a reference to an existing workbook/sheet):

Public Function CreateXL(Optional bVisible As Boolean = True) As Object

    Dim oTmpXL As Object

    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Defer error trapping in case Excel is not running. '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Set oTmpXL = GetObject(, "Excel.Application")

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'If an error occurs then create an instance of Excel. '
    'Reinstate error handling.                            '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo ERROR_HANDLER
        Set oTmpXL = CreateObject("Excel.Application")
    End If

    oTmpXL.Visible = bVisible
    Set CreateXL = oTmpXL

    On Error GoTo 0
    Exit Function

ERROR_HANDLER:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure CreateXL."
            Err.Clear
    End Select

End Function

This code gets the whole thing going (based on a query with two fields) - note I've passed a named query rather than a recordset:

Public Sub ExportToExcel()

    Dim oXL As Object
    Dim wrkBk As Object
    Dim colHeadings As Collection

    Set oXL = CreateXL
    Set wrkBk = oXL.workbooks.Add

    Set colHeadings = New Collection

    colHeadings.Add "First Field Name"
    colHeadings.Add "Second Field Name"

    With wrkBk
        QueryExportToXL wrkBk.worksheets(1), _
                        "Query1", _
                        , _
                        "An Alternative Sheet Name", _
                        wrkBk.worksheets(1).range("B5"), _
                        True, _
                        colHeadings
    End With

End Sub