アクセステーブルをExcelにエクスポートするが列のタイトルを変更する

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

私は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 

このコードは（2つのフィールドを持つクエリに基づいて）行く全部を取得する - 私は名前付きクエリではなく、レコードセットを通過しました注意：

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 

Answer 2

あなたがフレンドリ名を指定してまっすぐ選択クエリを作成します。

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

保存これと使用クエリの名前のエクスポート：

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