Access导出到Excel方法汇总

968次阅读

共计 3986 个字符，预计需要花费 10 分钟才能阅读完成。

提醒：本文最后更新于 2019-05-12 20:00，文中所关联的信息可能已发生改变，请知悉！

因为一个导出子窗体数据功能的需要, 查阅了好多的案例, 正好发现一个很好的帖子, 收藏下来, 以供以后学习查阅。

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

方法	优点	缺点
查询导出	可以根据查询设计 (直观)	格式固定
ADO 逐条遍历	写入位置可以灵活控制	速度较慢
CopyFromRecordset	速度极快	格式固定
Excel 插入 QueryTable	速度较快，可以汇总
复制粘贴	标题、格式和子窗体一致	只能导出数据表显示的子窗体数据

1、最简单的方法：VBA 调用 ACCESS 自带的导出功能

具体看下面的这篇文章。

VBA 调用 access 自带的导入导出数据功能

2、利用查询导出

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 语句

3、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

4、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

5、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

在某次发现了，可以手动复制子窗体上的数据，然后粘贴到 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‘粘贴数据

2—6 的方法以上摘自 http://www.accessoft.com/article-show.asp?id=17051

正文完