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