Question

我正在尝试将表格导出到Excel。我使用这段代码：

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

这很好但是，当它导出列时，每列的标题通常不是读者友好的（它使用典型的字段命名约定）。有没有办法将列标题更改为更友好的用户？

感谢

Answer 1

创建一个直接选择查询，您可以在其中指定友好名称：

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

保存此内容并在导出时使用查询名称：

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

Answer 2

我使用一种相当漫长的导出方式导出到Excel - 目前它只导出一个查询或记录集对象，但是一个简单的SELECT * FROM Table1会将你的表变成一个查询 - 或者代码可以更新为接受表格参考。

但是，它允许您指定标题文本，工作表名称和要导入的第一个单元格。

这是执行导出的代码：

'----------------------------------------------------------------------------------
' 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

在我的示例中，此代码是创建新的Excel工作簿所必需的（尽管您只能传递对现有工作簿/工作表的引用）：

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

此代码可以完成所有操作（基于具有两个字段的查询） - 注意我已经传递了命名查询而不是记录集：

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

将Access Table导出到Excel但更改列标题

2 个答案: