Access导出到Excel方法汇总

From：https://www.cnblogs.com/aademeng/articles/12951434.html

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                         '粘贴数据

https://www.cnblogs.com/aademeng/articles/12951434.html

一、ACCESS数据库加密
1、ACCESS 2013数据库加密方式
（1）使用旧版加密（适用于反向兼容和多用户数据）
（2）使用默认加密（安全性较高）
ADO连接仅支持旧版加密，使用VBA代码动态创建带密码的Access 数据库文件，也是旧版加密。
2、数据库如果采用手工设置密码，则要设置为旧版加密方式：
打开ACCESS 2013—Access选项—客户端设置—加密方法--使用旧版加密（适用于反向兼容和多用户数据）
二、设置ADO连接ACCESS数据库方式一
（1）引用 Microsoft ActiveX Data Objects 2.x Library（操作方式：Visual Basic-工具-引用，不同office版本不同）
  说明：当未引用，运行后会显示“用户定义类型未定义”
（2）连接代码
Sub 导入数据1()
    Dim cnn As ADODB.Connection      '数据库连接
    Dim mydata As String                   '数据库的完整路径和名称
    Dim mytable As String                  '数据表名称
    Dim sql As String                         'sql语句
    Dim rs As ADODB.Recordset          '临时数据表纪录
    Dim i As Integer                           '循环数据变量（获取数据表字段）

    '1、连接数据库
    Set cnn = New ADODB.Connection
    mydata = ThisWorkbook.Path & "进销存数据库.accdb"

    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password='123456'"
        .Open mydata
    End With

    '2、建立与数据库的连接
    mytable = "采购数据3"
    sql = "select 采购数据3.ID,采购数据3.采购日期,采购数据3.供货类型,采购数据3.采购分类,采购数据3.供应商,采购数据3.名称,采购数据3.单位,采购数据3.单价,采购数据3.数量,采购数据3.金额,采购数据3.入账日期" & " from " & mytable & " order by 采购日期"
    Set rs = New ADODB.Recordset
    rs.Open sql, cnn, adOpenKeyset, adLockOptimistic

     '3、复制数据库数据
    ' (1)清除原数据
    ActiveSheet.Cells.ClearContents

    '（2）复制字段名
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i

    '（3）复制全部数据
    Range("A2").CopyFromRecordset rs

    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing

End Sub


三、设置ADO连接ACCESS数据库方式二
无需引用，直接创建连接
Sub 导入数据2()
    Dim cnn As Object                '数据库连接
    Dim strcnn As String             'ACCESS连接语句
    Dim mydata As String            '数据库的完整路径和名称
    Dim mytable As String           '数据表名称
    Dim sql As String                  'sql查询语句
    Dim rs As Object                  '临时数据表纪录
    Dim i As Integer                  '循环数据变量（获取数据表字段）

    '1、连接数据库
    Set cnn = CreateObject("ADODB.Connection")
    mydata = ThisWorkbook.Path & "进销存数据库.accdb"

    Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
        Case Is <= 11
            strcnn = "Provider=Microsoft.Jet.Oledb.4.0;Jet OLEDB:Database Password='123456';Data Source=" & mydata
        Case Is >= 12
            strcnn = "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password='123456';Data Source=" & mydata
    End Select

    cnn.Open strcnn    '打开数据库链接

    '2、设置sql查询语句
    mytable = "采购数据3"
    Set rs = CreateObject("ADODB.Recordset")

    sql = "select 采购数据3.ID,采购数据3.采购日期,采购数据3.供货类型,采购数据3.采购分类,采购数据3.供应商,采购数据3.名称,采购数据3.单位,采购数据3.单价,采购数据3.数量,采购数据3.金额,采购数据3.入账日期" & " from " & mytable & " order by 采购日期"
    Set rs = cnn.Execute(sql)    '执行查询，并将结果输出到记录集对象

    '3、复制数据库数据

    With ActiveSheet
        .Cells.ClearContents

        For i = 0 To rs.Fields.Count - 1    '填写标题
            .Cells(1, i + 1) = rs.Fields(i).Name
        Next i

        .Range("A2").CopyFromRecordset rs

        '.Cells.EntireColumn.AutoFit  '自动调整列宽
        '.Cells.EntireColumn.AutoFit  '自动调整列宽

    End With


    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing

End Sub