怎样将Access数据库中的数据导出到excel里来？

Question

我是个刚学vb不到一周的初学者，希望大家的例子中带有详细的注释。
我的分数不多了，不够的话，我可以再给大侠们加。
在线等！谢谢大家不吝赐教。

Answer 1

'第一种方法
Private Sub AccessToExcel(AccessPath As String, AccessTablename As String, ExcelPath As String, ExcelSheet As String)
Dim dbSource As Database
Set dbSource = OpenDatabase(AccessPath)
dbSource.Execute ("SELECT * INTO " & ExcelSheet & " IN '" & ExcelPath & "' 'EXCEL 5.0;' FROM " & AccessTablename)
End Sub
'第二种方法
’下面的程序是本人自己编的，速度慢，但稳定且功能强大
Public Sub AccesstoExcel(AccessPath As String, AccessTablename As String, ExcelPath As String, ExcelSheetName As String)
Dim RsAccesstoExcel As New ADODB.Recordset
Dim CnAccesstoExcel As New ADODB.Connection
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.AddxlApp.Worksheets(ExcelSheetName).Activate
Dim i As Integer
Dim mm As Integer
Dim nn As Integer
Dim jj As IntegerCnAccesstoExcel.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessPath & ";Persist Security Info=False"
CnAccesstoExcel.CursorLocation = adUseClient
CnAccesstoExcel.Open
RsAccesstoExcel.Open "select * from " & AccessTablename, CnAccesstoExcel, adOpenDynamic, adLockOptimisticFor i = 1 To RsAccesstoExcel.Fields.Count
    xlApp.Cells(1, i).Value = RsAccesstoExcel.Fields.Item(i - 1).Name
Next
mm = 1
RsAccesstoExcel.MoveFirst
Do While RsAccesstoExcel.EOF <> True
   mm = mm + 1
    For nn = 1 To RsAccesstoExcel.Fields.Count
       If RsAccesstoExcel.Fields.Item(nn - 1).Value <> "" Then
       xlApp.Cells(mm, nn).Value = RsAccesstoExcel.Fields.Item(nn - 1).Value
       Else
       xlApp.Cells(mm, nn).Value = " "
       End If
    Next
   RsAccesstoExcel.MoveNext
Loop
xlApp.DisplayAlerts = False
xlBook.SaveAs (ExcelPath)
xlBook.Close (False)
Set xlApp = Nothing
If CnAccesstoExcel.State <> adStateClosed Then CnAccesstoExcel.Close
End SubDim xlApp As Excel.Application
Public Sub ExceltoAccess(ExcelPath As String, ExcelSheetName As String, AccessPath As String, AccessTableName As String)
Dim Rs As New ADODB.Recordset
Dim Cn As New ADODB.Connection
Dim dbs As Database
Dim tdfNew As TableDef
Set dbs = DBEngine.Workspaces(0).OpenDatabase(AccessPath, False, False)
On Error Resume Next
dbs.Execute ("drop table " & AccessTableName)
On Error GoTo 0
Set tdfNew = dbs.CreateTableDef(AccessTableName)
On Error GoTo 0Dim xlBook As Excel.Workbook
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open(ExcelPath) '打开已经存在的EXCEL工件簿文件
xlApp.Worksheets(ExcelSheetName).Activate
Dim i As Integer
Dim mm As Integer
Dim nn As Integer
Dim jj As Integer
i = 1Dim Fieldname As StringDo While xlApp.Cells(1, i).Value <> "" And Not IsNull(xlApp.Cells(1, i).Value)
   Fieldname = xlApp.Cells(1, i).Value
   tdfNew.Fields.Append tdfNew.CreateField(Fieldname, dbText)
   i = i + 1
Loop
dbs.TableDefs.Append tdfNew
Cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessPath & ";Persist Security Info=False"
Cn.CursorLocation = adUseClient
Cn.Open
Rs.Open "select * from " & AccessTableName, Cn, adOpenDynamic, adLockOptimistic
mm = 2 '行
nn = 1 '列
Do While CheckTable(mm, i - 1)
Rs.AddNew
    Do While nn <> i
        Rs.Fields.Item(nn - 1).Value = xlApp.Cells(mm, nn).Value
        If Rs.Fields.Item(nn - 1).Value = "" Or IsNull(Rs.Fields.Item(nn - 1)) Then
           Rs.Fields.Item(nn - 1).Value = "?"
        End If
    nn = nn + 1
    Loop
mm = mm + 1
nn = 1
Loop
Rs.Update
Set xlApp = Nothing
xlBook.Close (False)
If Cn.State <> adStateClosed Then Cn.Close
End Sub
Private Function CheckTable(NumberRow As Integer, NumberCol As Integer) As Boolean
   Dim ab As Integer, ac As Integer, YesNo As Boolean
   YesNo = False
   For ab = 0 To 5 '判断后5行是否有内容
       For ac = 1 To NumberCol
           If xlApp.Cells(NumberRow, ac).Value <> "" And Not IsNull(xlApp.Cells(NumberRow, ac).Value) Then
               YesNo = True
               GoTo Wanle
           End If
       Next
      NumberRow = NumberRow + 1
   Next
Wanle:
If YesNo = True Then CheckTable = True
If YesNo = False Then CheckTable = False
End Function

Answer 2

上贴给你贴了Option Explicit
'引用microsoft access 9.0 object library
Private Sub Command1_Click()
Dim acapp As Access.Application
Dim dbpath As String
Dim xpath As String
dbpath = App.Path & "\data.mdb"
xpath = App.Path & "\data.xls"Set acapp = GetObject(dbpath, "access.application")
acapp.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "[sheet1$]", xpathEnd Sub

Answer 3

Strsql = "SELECT No as 编号，Name as 姓名 danwei as 单位 INTO [Excel 8.0;DATABASE=" & Text1.Text & ".XLS].Sheet1] FROM exam_problem "

Answer 4

online(龙卷风V2.0--再战江湖) 谢谢您的帖子，上个帖子我已经结帖了，请查收您的分数。

Answer 5

online(龙卷风V2.0--再战江湖)
报错说：用户定义类型未定义。然后光标就停在了Dim acapp As Access.Application上
怎么语句中好象没有查询语句啊，那我怎么确定要导出哪个字段呢？

Answer 6

haohaohappy() 
我看第一中方法比较简单，可以给我参数说明吗？
最好给个例子加以详细的注释说明。谢谢您了。

Answer 7

online(龙卷风V2.0--再战江湖)
希望您给我个具体的例子，加以详细的注释说明。谢谢！

Answer 8

已经很清楚了'引用microsoft access 9.0 object library

Answer 9

参数说明?我那里没什么参数呀?只有几个变量,我这是个子程序,用时只需直接调用
AccessPath  是需要转化的ACCESS数据库路径
AccessTablename 是ACCESS数据库中需要转化的表名
ExcelPath  是要转化为EXCEL表的路径,也就是你要把ACCESS数据库中的这张表转化到哪里
ExcelSheet 是要转化到EXCEL表的哪个sheet页中
用的时候写
Call AccessToExcel后面挂参数就行了
另外需要说明的是第一种方法虽然好,但是不稳定,你可以试试转化下面的数据
12
34
23-56
23-LL
34
你会发现23-56和23-LL都没有转化过来
第二种方法就是我针对这个问题自己编的,用法和第一种一样.

Answer 10

online(龙卷风V2.0--再战江湖)
上一个报错是因为我没有引用microsoft access 9.0 object library
但是我引用后又有新的错误：
说 "[sheet1$]"为遵循microsoft access 对象的命名规则。望赐教。另外我发现这个程序必须要自己创建excel文件。能不能从程序里创建，并将数据写入呢？谢谢！

Answer 11

haohaohappy() 
您的第二个方法确实可行，但是我想只显示数据库表格中的某些字段怎么办，我还想在程序中创建excel文件，并保存。您的程序好像需要自己创建excel文件，并且字段名也和数据库中的一样。怎么更改字段名，以及选取个别字段导出呢？谢谢！