如何将Access中的数据用<em>VBA</em>写入Excel中

Access中点击你的数据，直接另存为 选择EXCEL格式就行了

1. 打开EXCEL表，将其中一个表单e69da5e887aae799bee5baa6e79fa5e98193361取名为“Result"，假设你的Access数据库在C:\TEST.accdb;数据库表名为Test01
2. 将下面代码植入宏编辑器中,注意引用Excel控件MS ActiveX object 2.6和DAO 3.6
Sub ReadAccessToExcel()
Set ReadCooisCn = New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim RstX As New ADODB.Recordset

With ReadCooisCn
.Provider = "Microsoft.ACE.OLEDB.12.0;Data source=" _
& "C:\Test.accdb;Persist Security Info=False;"
.Open
End With
Sqlstr = "select * from Table01"

Rst.Open Sqlstr, ReadCooisCn, adOpenKeyset, adLockOptimistic

If Rst.RecordCount > 0 Then
worksheets("Result").cells(1,1).CopyFromRecordset Rst
End If

Rst.Close
Set Rst = Nothing
ReadCooisCn.Close
end Sub
用ADO把查询表的数据导到Excel表上e799bee5baa6e58685e5aeb9361（记得引用ADO和 Microsoft Excell 11.0 Objec Library)，给一个例子的代码，供参考：
Private Sub Command1_Click()
On Error Resume Next
Dim oExcel As Object
Dim oBook As Object
Dim K As Integer
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add()
With oBook.Worksheets(1)
With oBook.Worksheets(1).PageSetup ’设定页面边距
.LeftMargin = 0.275590551181102
.RightMargin = 0.275590551181102
.TopMargin = 0.275590551181102
.BottomMargin = 0.275590551181102

.Columns("A:A").ColumnWidth = 6 '设定Excel各列的宽度
.Columns("B:B").ColumnWidth = 5.2
.Columns("C:C").ColumnWidth = 10.5
.Columns("D:D").ColumnWidth = 25.7
.Columns("E:E").ColumnWidth = 6
.Columns("F:F").ColumnWidth = 4
.Columns("G:G").ColumnWidth = 3
.Columns("H:H").ColumnWidth = 4
.Columns("I:I").ColumnWidth = 2
.Columns("J:J").ColumnWidth = 7
.Columns("K:K").ColumnWidth = 1
.Columns("L:L").ColumnWidth = 9.9
.Columns("M:M").ColumnWidth = 2.5
.Rows(8).RowHeight = 20.1 '设定Excel各行的高度
Rows(9).RowHeight = 18
.Cells(1, 4) = " 购 销 合 同"
.Cells(1, 4).Font.Size = 20
.Cells(1, 4).Font.Bold = True
.Cells(3, 8) = " 编号:"
.Cells(4, 8) = " 日期:"
.Cells(5, 8) = " 项目名称:"
.Cells(3, 1) = "卖方:"
.Cells(4, 1) = "地址:"

.Cells(6, 1) = " 买卖双方同意订立下列条款进行购销XXXXXXXXXXX"
.Cells(8, 1) = "数 量"
.Cells(8, 3) = " 货 号"
.Cells(8, 4) = " 品 名"
.Cells(8, 5) = " 颜 色"
.Cells(8, 6) = " 含 量"
.Cells(8, 8) = "箱 数"
.Cells(8, 10) = " 单 价"
.Cells(8, 12) = " 金 额"
.Range(.Cells(8, 1), .Cells(8, 13)).Borders(xlEdgeTop).LineStyle = xlContinuous '刬线
.Range(.Cells(8, 1), .Cells(8, 13)).Borders(xlEdgeTop).Weight = xlThick
.Range(.Cells(8, 1), .Cells(8, 13)).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Range(.Cells(8, 1), .Cells(8, 13)).Borders(xlEdgeBottom).Weight = xlThin
Dim CN As New ADODB.Connection
Dim ST As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
CN.Open "provider=microsoft.jet.oledb.4.0;data source=" & App.Path & "\表名.mdb"

ST = "select * from 查询表"

rs.Open ST, CN, adOpenKeyset, adLockOptimistic
rs.MoveFirst

For K = 1 To rs.RecordCount '把查询表的内容写到Excel表中指定位置
.Cells(K + 8, 1) = rs("QTY")
.Cells(K + 8, 2) = rs("OUN")
.Cells(K + 8, 3) = rs("ITEM")
.Cells(K + 8, 4) = rs("CDES")
.Cells(K + 8, 5) = rs("COL")
.Cells(K + 8, 6) = rs("OPACK")
.Cells(K + 8, 7) = rs("OUN")
.Cells(K + 8, 8) = rs("CTN")
.Cells(K + 8, 10) = Left(rs("PRICE"), 6)
.Cells(K + 8, 10).NumberFormatLocal = "0.00_ "
.Cells(K + 8, 12) = Left(rs("AMT"), 9)
.Cells(K + 8, 12).NumberFormatLocal = "0.00_ "
rs.MoveNext
Next K
.Cells(K + 9, 10) = "合计:"
.Cells(K + 9, 13) = "元"
End With

rs.Close
Set rs = Nothing
Set Cn=nothing
oExcel.Visible = True
Set oBook = Nothing
Set oExcel = Nothing

End Sub

给你一段代码，修改下即可！
第一步：创建一个e68a84e8a2ade799bee5baa6362Excel的链接表！
'输入目录向数据库链接一个Excel表 并且加上 "XL"
Sub LinkInxlsData(strSelectDir As String, tabName As String)
On Error GoTo Err_InExcel

Dim rst1 As ADODB.Recordset
Dim cat1 As New ADOX.Catalog
Dim tbl1 As ADOX.Table
Dim strXLtab As String

strXLtab = "XL" & tabName

cat1.ActiveConnection = CurrentProject.Connection
For Each tbl1 In cat1.Tables
If tbl1.Name = strXLtab Then
cat1.Tables.Delete (strXLtab)
End If
Next tbl1
'链接这个Excel表
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel97, strXLtab, strSelectDir, -1, tabName
Application.RefreshDatabaseWindow

Exit_InExcel:
Exit Sub
Err_InExcel:
MsgBox "在你指定的目录下没有你要找的文件，请重新选择路径！", vbExclamation, "迈和瑞软件提示 导入错误"
Resume Exit_InExcel
End Sub

'删除一个指定的链接表
Sub DelLinkAccTable(tabName As String)
Dim cat1 As New ADOX.Catalog
Dim tbl1 As ADOX.Table

cat1.ActiveConnection = CurrentProject.Connection
For Each tbl1 In cat1.Tables
If tbl1.Name = tabName Then
cat1.Tables.Delete (tabName)
End If
Next tbl1
Application.RefreshDatabaseWindow
End Sub

第二步：连接好后，调用这个函数，追加数据到目标表
'链接一个表然后追加数据到当前数据库的表
Sub LinkAddAccDataTomyDB(mystrdir As String, inputTab As String)

Dim myTab As String, myMDBtab As String
Dim strSQL As String

myTab = inputTab
myMDBtab = "MDB" & inputTab
'Debug.Print mystrdir, mytab
'链接这个Excel表
LinkAccessTable mystrdir, myTab
'追加数据
strSQL = "INSERT INTO " & "[" & myTab & "]" & " SELECT " & "[" & myMDBtab & "]" & ".* FROM " & "[" & myMDBtab & "]" & ";"
'Debug.Print strSQL
Call MeExecuteSQL(strSQL)

'删除链接表
DelLinkAccessTable myMDBtab

'MsgBox "数据导入成功！", vbInformation, AccMsgTitl
End Sub

最后：导入完成，用上面删除链接表的程序删除链接表！