将访问 Table 导出到 Excel 但更改列标题
Exporting Access Table to Excel but change column titles
我正在尝试将 table 导出到 Excel。我使用此代码：
fileName = "My_Export_" & DateDiff("s", #1/1/1970#, Now()) & ".xlsx"
exportPath = CurrentProject.Path & "\SomeFolder\" & fileName
DoCmd.TransferSpreadsheet acExport, 10, "myTtableName", exportPath, True
这很好用，但是当它导出列时，每列的标题通常 reader 不友好（它使用典型的字段命名约定）。有没有办法将列标题更改为更用户友好的内容？
谢谢
我使用一种相当冗长的方式导出到 Excel - 目前它只导出一个查询或记录集 object，但是一个简单的 SELECT * FROM Table1 将把你的 table 进入查询 - 或者可以更新代码以接受 table 引用。
但是，它允许您指定 header 文本、sheet 名称和要导入到的第一个单元格。
这是执行导出的代码：
'----------------------------------------------------------------------------------
' 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 工作簿需要此代码（尽管您可以只传递对现有 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
这段代码让整个事情顺利进行（基于具有两个字段的查询）——注意我传递的是命名查询而不是记录集：
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
创建直接 select 查询，您可以在其中指定友好名称：
Select
SomeField As [New Sales],
AnotherField As [Sales District],
SomeOtherField As [Sales Volume]
From
myTableName
保存此内容并在导出时使用您的查询名称：
DoCmd.TransferSpreadsheet acExport, 10, "SavedQueryName", exportPath, True
我正在尝试将 table 导出到 Excel。我使用此代码：
fileName = "My_Export_" & DateDiff("s", #1/1/1970#, Now()) & ".xlsx"
exportPath = CurrentProject.Path & "\SomeFolder\" & fileName
DoCmd.TransferSpreadsheet acExport, 10, "myTtableName", exportPath, True
这很好用，但是当它导出列时，每列的标题通常 reader 不友好（它使用典型的字段命名约定）。有没有办法将列标题更改为更用户友好的内容？
谢谢
我使用一种相当冗长的方式导出到 Excel - 目前它只导出一个查询或记录集 object，但是一个简单的 SELECT * FROM Table1 将把你的 table 进入查询 - 或者可以更新代码以接受 table 引用。
但是，它允许您指定 header 文本、sheet 名称和要导入到的第一个单元格。
这是执行导出的代码：
'----------------------------------------------------------------------------------
' 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 工作簿需要此代码（尽管您可以只传递对现有 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
这段代码让整个事情顺利进行（基于具有两个字段的查询）——注意我传递的是命名查询而不是记录集：
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
创建直接 select 查询，您可以在其中指定友好名称：
Select
SomeField As [New Sales],
AnotherField As [Sales District],
SomeOtherField As [Sales Volume]
From
myTableName
保存此内容并在导出时使用您的查询名称：
DoCmd.TransferSpreadsheet acExport, 10, "SavedQueryName", exportPath, True