设为首页收藏本站Access中国
开启辅助访问 切换到宽版

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步，快速开始

Office中国论坛/Access中国论坛»论坛首页 › ACCESS 与Sql Server 讨论区 › Access常规交流 › 【总结】Access导出到Excel方法汇总
返回列表 发新帖
查看: 5648|回复: 2
打印 上一主题 下一主题

[模块/函数] 【总结】Access导出到Excel方法汇总

[复制链接]
盗梦

点击这里给我发消息
跳转到指定楼层
1#
发表于 2015-10-29 13:47:34 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 盗梦 于 2015-10-29 15:35 编辑

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

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

1、利用查询导出
  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。
  1.     Dim rs As New ADODB.Recordset
  2.     Dim xlApp As Object     'Excel.Application
  3.     Dim xlBook As Object    'Excel.Workbook
  4.     Dim xlSheet As Object   'Excel.Worksheet

  6.     Set xlApp = CreateObject("Excel.Application")
  7.     Set xlBook = xlApp.Workbooks.Add    '添加一个新的Book
  8.     Set xlSheet = xlApp.ActiveSheet     '使用当前的Sheet

  10.     Dim strSql As String
  11.     Dim i As Long

  13.     strSql="Select * from 表1 where ID<10"
  14.     rs.Open strSql, CurrentProject.Connection, 1, 1
  15.         Do While Not rs.EOF
  16.             xlSheet.Cells(2 + i,1)=rs("ID")   '从第2行开始写数据
  17.             xlSheet.Cells(2 + i,2)=rs("FName")
  18.             rs.MoveNext
  19.             i=i+1
  20.         Loop
  21.     rs.Close

  23.     xlApp.Visible=True
复制代码


3、CopyFromRecordset导出数据
CopyFromRecordset是Excel vba的方法，可以快速把一个记录集的数据填充到Excel单元格中。
  1. '标题：根据SQL语句，快速导出到Excel文件
  2. '作者：阿航

  4. '创建日期：2015-01-10
  5. '说明：
  6. '   - 会将SQL语句的字段名作为标题。可以用As的方式设置对应字段的标题，如果是关键字，要加中括。
  7. '   - 示例：ExportToExcel "select FID as [ID], FText as 文本 from 表1"

  9. '更新日期：2015-09-05
  10. '   - 添加一个长度可变的参数，用于传递标题
  11. '   - 示例：ExportToExcel "select FID,FText from 表1","主键","文本"
  12. Public Function ExportToExcel(strSql As String, ParamArray VarExpr() As Variant) As Boolean
  13.     Dim rs As Object        'DAO.Recordset（用ADO也行）
  14.     Dim xlApp As Object     'Excel.Application
  15.     Dim xlBook As Object    'Excel.Workbook
  16.     Dim xlSheet As Object   'Excel.Worksheet
  17.     Dim i As Integer
  18.          
  19.     '创建Excel文件
  20. On Error GoTo Err_Show
  21.     Set xlApp = CreateObject("Excel.Application")
  22.     Set xlBook = xlApp.Workbooks.Add    '添加一个新的Book
  23.     Set xlSheet = xlApp.ActiveSheet     '使用当前的Sheet
  24.          
  25.     Set rs = CurrentDb.OpenRecordset(strSql)
  26.     '先写入标题(可以考虑用DAO的字段标题属性 rs(i-1).Properties("Caption"))
  27. '    For i = 1 To rs.Fields.Count
  28. '        xlSheet.cells(1, i) = rs(i - 1).Name
  29. '    Next
  30.     '更新部分（2015-09-05）长度可变的参数，相当于一个数组
  31.     For i = 0 To UBound(VarExpr)
  32.         xlSheet.cells(1, i + 1) = VarExpr(i)
  33.     Next
  34.               
  35.     '再写入数据
  36.     xlSheet.Range("A2").CopyFromRecordset rs
  37.     rs.Close
  38.          
  39.     '调整列宽
  40.     xlSheet.Columns.EntireColumn.AutoFit
  41.     xlApp.Visible = True
  42.     xlBook.Activate
  43.     ExportToExcel = True
  44.          
  45. Err_Exit:
  46.     Set xlSheet = Nothing
  47.     Set xlBook = Nothing
  48.     Set xlApp = Nothing
  49.     Set rs = Nothing
  50.     Exit Function
  51. Err_Show:
  52.     MsgBox "导出出错，请重新尝试" & vbCrLf & Err.Description, "导出出错"
  53.     On Error Resume Next
  54.     '出错则清掉文件，避免有多个Excel进程
  55.     xlBook.Close False
  56.     If xlApp.Workbooks.Count = 0 Then xlApp.Quit
  57.     GoTo Err_Exit
  58. End Function
复制代码


4、Excel插入QueryTable
QueryTable是Excel的一种表格对象，可以插入一个DAO记录集
  1. '---用记录填充Excel表格
  2. '输入参数: RS,需要填充的记录集
  3. '          InsertSheet, 需要填充的Excel工作表
  4. '          InsertSheet, 需要开始填充的单元格
  5. '返回参数, 填充完毕的range

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

  11.     '根据记录集生成一个querytable
  12.     rsInsert.MoveFirst

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

  16.     With qtTable
  17.         .FieldNames = True
  18.         .AdjustColumnWidth = True
  19.         .Refresh BackgroundQuery:=False
  20.     End With


  23.     ' 把QueryTable ListObject
  24.     Set loListObject = sheetInsert.ListObjects.Add(xlSrcRange, qtTable.ResultRange, , xlYes)

  26.     With loListObject
  27.         .ShowTotals = True   '显示汇总列
  28.         .ShowAutoFilter = True

  30.         '显示汇总数据
  31.         Dim fld As DAO.Field
  32.         For Each fld In rsInsert.Fields
  33.             Select Case fld.Type
  34.                 Case dbCurrency
  35.                     '.ListColumns(fld.Name).TotalsCalculation = xlTotalsCalculationSum
  36.                     .ListColumns(fld.Name).Range.NumberFormat = "#,##0.00;-#,##0.00"

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

  44.         '.Range.AutoFormat xlRangeAutoFormatList1
  45.         Set FillRS = .Range
  46.         .Unlink
  47.         .Unlist
  48.     End With

  50.     Set qtTable = Nothing
  51. End Function
复制代码


5、复制粘贴的方法，快速导出数据
在某次发现了，可以手动复制子窗体上的数据，然后粘贴到Excel中。于是就尝试用这代码实现这个功能
  1.     Me.子窗体控件名.SetFocus                    '子窗体控件获得焦点
  2.     DoCmd.RunCommand acCmdSelectAllRecords      '选中所有记录
  3.     DoCmd.RunCommand acCmdCopy                  '复制
  4.     DoEvents

  6.     Dim Obj As Object
  7.     Set Obj = CreateObject("excel.application") '创建Excel对象
  8.     Obj.workbooks.Add                           '新建工作簿
  9.     Obj.Visible = True                          '设为可见
  10.     SendKeys "^v", True                         '粘贴数据
复制代码


当然，还有其他各种方法，例如利用OpenXML方法导出。大家可以回复讨论交流一下。

评分

参与人数 1经验 +10 金钱 +10 技术 +1 V币 +1 收起 理由
5988143 + 10 + 10 + 1 + 1 （其它）优秀教程、原创内容、以资鼓励、其.

查看全部评分

分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏2 分享分享 分享淘帖 订阅订阅
回复

使用道具 举报

风中漫步
2#
发表于 2015-10-29 14:58:16 | 只看该作者
好贴.
回复

使用道具 举报

yanwei82123300
3#
发表于 2015-10-30 07:39:55 | 只看该作者
总结不错！谢谢分享
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-29 04:42 , Processed in 0.117812 second(s), 28 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表