Access導出到Excel方法匯總

時　間:2018-02-06 23:05:58
作　者:mabaor   ID：416  城市：青銅峽
摘　要:因為一個導出功能的需要,查閱了好多的案例,正好發現在OFFICE-中國有這樣一個很好的帖子,收藏下來,以供以后學習查閱,也供其它朋友收藏使用
正　文:

Access vba有各種方法可以導出到Excel，大致如下：

 

方法	優點	缺點
查詢導出	可以根據查詢設計(直觀)	格式固定
ADO逐條遍歷	寫入位置可以靈活控制	速度較慢
CopyFromRecordset	速度極快	格式固定
Excel插入QueryTable	速度較快，可以匯總
復制粘貼	標題、格式和子窗體一致	只能導出數據表顯示的子窗體數據

1、利用查詢導出

DoCmd.OutputTo acOutputQuery, "具體的查詢名稱", acFormatXLS, , True

執行這條語句，即可把對應的查詢導出到Excel文件

拓展：
1）、當然，你也可以根據SQL語句自動創建查詢，再導出。
    CurrentDb.CreateQueryDef "新的查詢名稱", "SQL語句"  '創建查詢
2）、然后，導出之后，你可以刪除掉這個查詢
    DoCmd.DeleteObject acQuery, "查詢名稱"            '刪除查詢
3）、當然，你可以修改當前查詢的SQL語句之后，再導出

 

    Dim qdf As Object  'DAO.QueryDef
    Set qdf = CurrentDb.QueryDefs("查詢名稱")
    qdf.SQL = strSQL   '設置新的SQL語句

 

 

2、ADO逐條遍歷
這種方法是最傳統和最典型的方法，也是最靈活的。

打開一個記錄集，然后遍歷數據對Excel操作即可。重點在操作Excel。

 

                                                        
    Dim rs As New ADODB.Recordset
    Dim xlApp As Object     'Excel.Application
    Dim xlBook As Object    'Excel.Workbook
    Dim xlSheet As Object   'Excel.Worksheet
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add    '添加一個新的Book
    Set xlSheet = xlApp.ActiveSheet     '使用當前的Sheet
    Dim strSql As String
    Dim i As Long
    strSql="Select * from 表1 where ID<10"
    rs.Open strSql, CurrentProject.Connection, 1, 1
        Do While Not rs.EOF
            xlSheet.Cells(2 + i,1)=rs("ID")   '從第2行開始寫數據
            xlSheet.Cells(2 + i,2)=rs("FName")
            rs.MoveNext
            i=i+1
        Loop
    rs.Close
    xlApp.Visible=True

3、CopyFromRecordset導出數據
CopyFromRecordset是Excel vba的方法，可以快速把一個記錄集的數據填充到Excel單元格中。

'標題：根據SQL語句，快速導出到Excel文件
'作者：阿航

'創建日期：2015-01-10
'說明：
'   - 會將SQL語句的字段名作為標題。可以用As的方式設置對應字段的標題，如果是關鍵字，要加中括。
'   - 示例：ExportToExcel "select FID as [ID], FText as 文本 from 表1"
'更新日期：2015-09-05
'   - 添加一個長度可變的參數，用於傳遞標題
'   - 示例：ExportToExcel "select FID,FText from 表1","主鍵","文本"
Public Function ExportToExcel(strSql As String, ParamArray VarExpr() As Variant) As Boolean
    Dim rs As Object        'DAO.Recordset（用ADO也行）
    Dim xlApp As Object     'Excel.Application
    Dim xlBook As Object    'Excel.Workbook
    Dim xlSheet As Object   'Excel.Worksheet
    Dim i As Integer
          
    '創建Excel文件
On Error GoTo Err_Show
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add    '添加一個新的Book
    Set xlSheet = xlApp.ActiveSheet     '使用當前的Sheet
          
    Set rs = CurrentDb.OpenRecordset(strSql)
    '先寫入標題(可以考慮用DAO的字段標題屬性 rs(i-1).Properties("Caption"))
'    For i = 1 To rs.Fields.Count
'        xlSheet.cells(1, i) = rs(i - 1).Name
'    Next
    '更新部分（2015-09-05）長度可變的參數，相當於一個數組
    For i = 0 To UBound(VarExpr)
        xlSheet.cells(1, i + 1) = VarExpr(i)
    Next
              
    '再寫入數據
    xlSheet.Range("A2").CopyFromRecordset rs
    rs.Close
          
    '調整列寬
    xlSheet.Columns.EntireColumn.AutoFit
    xlApp.Visible = True
    xlBook.Activate
    ExportToExcel = True
          
Err_Exit:
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Set rs = Nothing
    Exit Function
Err_Show:
    MsgBox "導出出錯，請重新嘗試" & vbCrLf & Err.Description, "導出出錯"
    On Error Resume Next
    '出錯則清掉文件，避免有多個Excel進程
    xlBook.Close False
    If xlApp.Workbooks.Count = 0 Then xlApp.Quit
    GoTo Err_Exit
End Function

4、Excel插入QueryTable
QueryTable是Excel的一種表格對象，可以插入一個DAO記錄集

'---用記錄填充Excel表格
'輸入參數: RS,需要填充的記錄集
'          InsertSheet, 需要填充的Excel工作表
'          InsertSheet, 需要開始填充的單元格
'返回參數, 填充完畢的range


Public Function FillRS(ByRef rsInsert As DAO.Recordset, ByRef sheetInsert As Excel.Worksheet, rangeInsert As Excel.Range) As Excel.Range
    Dim qtTable As Excel.QueryTable
    Dim loListObject As Excel.ListObject

    '根據記錄集生成一個querytable
    rsInsert.MoveFirst

    Set qtTable = sheetInsert.QueryTables.Add(Connection:=rsInsert, Destination:=rangeInsert)

    With qtTable
        .FieldNames = True
        .AdjustColumnWidth = True
        .Refresh BackgroundQuery:=False
    End With
' 把QueryTable ListObject
    Set loListObject = sheetInsert.ListObjects.Add(xlSrcRange, qtTable.ResultRange, , xlYes)

    With loListObject
        .ShowTotals = True   '顯示匯總列
        .ShowAutoFilter = True

        '顯示匯總數據
        Dim fld As DAO.Field
        For Each fld In rsInsert.Fields
            Select Case fld.Type
                Case dbCurrency
                    '.ListColumns(fld.Name).TotalsCalculation = xlTotalsCalculationSum
                    .ListColumns(fld.Name).Range.NumberFormat = "#,##0.00;-#,##0.00"

                Case dbDate
                    .ListColumns(fld.Name).Range.NumberFormat = "yyyy-mm-dd;@"
            End Select
        Next
        '.TableStyle = "TableStyleMedium9"

        '.Range.AutoFormat xlRangeAutoFormatList1
        Set FillRS = .Range
        .Unlink
        .Unlist
    End With

    Set qtTable = Nothing
End Function

5、復制粘貼的方法，快速導出數據
在某次發現了，可以手動復制子窗體上的數據，然后粘貼到Excel中。於是就嘗試用這代碼實現這個功能

 Me.子窗體控件名.SetFocus                    '子窗體控件獲得焦點
    DoCmd.RunCommand acCmdSelectAllRecords      '選中所有記錄
    DoCmd.RunCommand acCmdCopy                  '復制
    DoEvents

    Dim Obj As Object
    Set Obj = CreateObject("excel.application") '創建Excel對象
    Obj.workbooks.Add                           '新建工作簿
    Obj.Visible = True                          '設為可見
    SendKeys "^v", True                         '粘貼數據

Access軟件網官方交流QQ群 (群號:115120150) 　　　　　　access源碼網店