求简单的ACCESS中某表导入EXCEL中表的程序或是模块，急求！！！！！李洪根在吗？

Question

我知道EXCEL表导入到ACCESS中的程序，并写成模块，程序如下：'EXCEL导入ACCESS模块声明
Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
    Dim db As Database
    Dim rs As Recordset    Set db = OpenDatabase(sExcelPath, True, False, "Excel 8.0")
    Call db.Execute("Delete * from  [;database=" & App.Path & sAccessDBPath & "]." & sAccessTable & " ")
    Call db.Execute("Insert Into  [;database=" & App.Path & sAccessDBPath & "]." & sAccessTable & " Select *  FROM [" & sSheetName & "$]")
End Sub在程序中调用如下语句：
    ExportExcelSheetToAccess "sSheetName", "sExcelPath", "AccessTable", "sAccessDBPath"并在工程中引用 Miscrosoft DAO 3.6 即可。
 
不知 ACCESS导出为EXCEL是否也有类似的模块或程序，或是其他的，只要功能够用就好。谢谢各位！高分致上！

Answer 1

'ACCESS导出为EXCELPrivate Sub Command1_Click()
        Dim Conn As New ADODB.Connection
        Dim Rs As New ADODB.Recordset
        Dim ExcelApp As New Excel.Application
        Dim WorkBookObj As Workbook
        Dim SheetObj As Worksheet
        
        
        Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\BakDatabase.mdb"
        Conn.Open
        Rs.Open "Select * From TrapLog", Conn, adOpenKeyset, adLockOptimistic, adCmdText
        '==========================================================================
        Set WorkBookObj = ExcelApp.Workbooks.Open(App.Path & "\abc.xls")
        Set SheetObj = WorkBookObj.Worksheets(1)
        '========================================
        SheetObj.Range("A1").CopyFromRecordset Rs
        '========================================
        With SheetObj.PageSetup                    '页眉页脚设置
            .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
            .CenterHeader = "&""楷体_GB2312,常规""我的公司名称&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
            .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
            .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
            .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
            .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
            End With
        '========================================
        SheetObj.Name = "abc"
        Set SheetObj = Nothing
        WorkBookObj.Save
        WorkBookObj.Close
        Set WorkBookObj = Nothing
        ExcelApp.Quit
        Set ExcelApp = Nothing
        Rs.Close
        Set Rs = Nothing
        Conn.Close
        Set Conn = Nothing
        MsgBox "OK!请您打开abc.xls文件察看!"
End Sub

Answer 2

是否可以写成模块，然后在程序中调用即可。
因为需要在程序中同时将ACCESS中的 多个表同时 导出为EXCEL文件中的多个Sheet中，其中EXCEL文件中每个Sheet的名字以ACCESS中的表命名。
谢谢各位帮忙！

Answer 3

Public Sub ExportAccessToExcelSheet(sSheetName As String, sExcelPath As String, AccessTable As String, sAccessDBPath As String)
Dim Conn As New ADODB.Connection
        Dim Rs As New ADODB.Recordset
        Dim ExcelApp As New Excel.Application
        Dim WorkBookObj As Workbook
        Dim SheetObj As Worksheet
        
        
        Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sAccessDBPath
        Conn.Open
        Rs.Open "Select * From " & AccessTable, Conn, adOpenKeyset, adLockOptimistic, adCmdText
        '==========================================================================
        Set WorkBookObj = ExcelApp.Workbooks.Open(sExcelPath)
        Set SheetObj = WorkBookObj.Worksheets(1)
        '========================================
        SheetObj.Range("A1").CopyFromRecordset Rs
        SheetObj.Name = sSheetName
        Set SheetObj = Nothing
        WorkBookObj.Save
        WorkBookObj.Close
        Set WorkBookObj = Nothing
        ExcelApp.Quit
        Set ExcelApp = Nothing
        Rs.Close
        Set Rs = Nothing
        Conn.Close
        Set Conn = Nothing
End Sub
'调用
ExportAccessToExcelSheet "sSheetName", "sExcelPath", "AccessTable", "sAccessDBPath"
还要引用microsoft Excel 11.0 Object Library和microsoft ActiveX Data Objects 2.0 Library

Answer 4

谢谢！导出功能基本实现。但是，如何才能将ACCESS中表的字段名也导出，导出为EXCEL的每列的开头呀。谢谢！

Answer 5

还有：
  每次调用，如果是同一个EXCEL文件时，只能保证插入一个SHEET中，不能保证插入多个SHEET中，被插入数据的永远是原来EXCEL中的SHEET1。
  希望能够插入至少9张SHEET表。不需要排序，只要ACCESS中Table与EXCEL中的Sheet一一对应即可。
  谢谢

Answer 6

to ： lioner9944(仙道) 
上面的代码是：
Set SheetObj = WorkBookObj.Worksheets(1)当然每次都是一个SHEET

Answer 7

Dim Conn   As New ADODB.Connection                '定义数据库的连接
Dim Rs   As New ADODB.Recordset
Conn.ConnectionString = "Provider=sqloledb;Data Source=10.0.0.100;Initial Catalog=northwind;User Id=sa;Password=xingeedoc2004;"Conn.Open
Rs.CursorLocation = adUseClient
Rs.Open "select * from employees", Conn, adOpenDynamic, adLockOptimisticDim ExcelApp As New Excel.Application
Dim WorkBookObj As Workbook
Dim SheetObj As Worksheet
Set WorkBookObj = ExcelApp.Workbooks.Open("d:\aa.xls")
Set SheetObj = WorkBookObj.Worksheets.Add
SheetObj.Range("A1").CopyFromRecordset Rs
Set SheetObj = Nothing
WorkBookObj.Save
WorkBookObj.Close
Set WorkBookObj = Nothing
ExcelApp.Quit
Set ExcelApp = Nothing
Rs.Close
Set Rs = Nothing
Conn.Close
Set Conn = Nothing

Answer 8

每次的工作表都是添加一个
Set SheetObj = WorkBookObj.Worksheets.Add

Answer 9

还是要麻烦大家了！请问各位如何将导入的ACCESS中TABLE的FIELDNAME设为EXCEL的SHEET的第一行数据？？？谢谢，在线等

Answer 10

Case "输出到文件：Excel 8.0"
        dbf.Execute "SELECT * INTO [Excel 8.0;DATABASE=" & prn_out_filename & "].[" & Trim(txtmaintitle.Text) & "] FROM [临时表_打印输出]"
        '注意事项:
        '1、authors.XLS 可事先存在，也可以不存在，会自动产生一个。
        '2、工作表 authors 事先不可存在，否则会产生错误    Case "输出到文件：TXT"
    Case "输出到文件：TXT"
        prn_out_filename = fs.GetFileName(prn_out_filename)
        dbf.Execute "SELECT * INTO [Text;DATABASE=" & prn_out_path & "].[" & prn_out_filename & "] FROM [临时表_打印输出]"
        '注意事项:
        '1、authors.TXT 事先不可存在，否则会产生错误！
        '2、此动作会产生的文件有二个，第一个就是文本文件 authors.TXT，第二个是 Schema.ini。
        '3、文本文件之格式为 CSV 之文件格式，即各栏位间以逗点分开
    Case "输出到文件：Html"
        prn_out_filename = fs.GetFileName(prn_out_filename)
        dbf.Execute "SELECT * INTO [HTML Export;DATABASE=" & prn_out_path & "].[" & prn_out_filename & "] FROM [临时表_打印输出]"
        '注意事项:
        '1、authors.HTM 事先不可存在，否则会产生错误！
        '2、此动作会产生的文件有二个，第一个就是文本文件 authors.HTM，第二个是 Schema.ini。
    Case "输出到文件：DBase"
        prn_out_filename = fs.GetFileName(prn_out_filename)
        dbf.Execute "SELECT * INTO [dBase III;DATABASE=" & prn_out_path & "].[" & prn_out_filename & "] FROM [临时表_打印输出]"
        '注意事项:
        '1、authors.DBF 事先不可存在，否则会产生错误！

Answer 11

Case "输出到文件：Excel 8.0"
        dbf.Execute "SELECT * INTO [Excel 8.0;DATABASE=" & prn_out_filename & "].[" & Trim(txtmaintitle.Text) & "] FROM [临时表_打印输出]"

Answer 12

Private Function myQuery(pgb As ProgressBar, labTiShi As Label, strWhere As String) As Boolean
On Error GoTo err1
    '将普通查询结果传送到Excel
    Dim clsX As Long      '记录列数
    Dim SQL As String
    Dim i As Long
    Dim j As Long
    '检查输入数据
    If Len(strWhere) < 1 Then
        PuTongChaXun = False
        Exit Function
    Else
        '生成查询语句
        SQL = strWhere
    End If        '生成Excel对象
        Set exl = New excel.Application
        '生成Excel空工作表
        exl.Workbooks.Add
        exl.Application.IgnoreRemoteRequests = True        '连接数据库
        Data.openCon
        If rs.State <> 0 Then
            rs.Close
        End If
        '打开查询记录集合
        rs.Open SQL, Data.Con, adOpenStatic
        '检查集合数量
        If rs.EOF = True Then
            rs.Close
            exl.DisplayAlerts = False
            exl.Application.IgnoreRemoteRequests = False
            exl.Quit
            exl.DisplayAlerts = True
            Set exl = Nothing
            Exit Function
        Else
            Dim rsF As Field
            rs.MoveLast
            '保存记录集总数
            clsNum = rs.RecordCount
            '取得记录列数
            For Each rsF In rs.Fields
                clsX = clsX + 1
            Next
            '设置数组变量
            ReDim clsTable(clsX, clsNum)
            '将表头写入数组
            For i = 0 To clsX - 1
                clsTable(i, 0) = rs.Fields(i).Name
            Next
            
            '重置进度条状态
            pgb.Min = 0                '进度条最小值
            pgb.Max = clsNum + 1       '进度条最大值
            pgb.Value = 0              '进度条状态值
            rs.MoveFirst
            
            '向数组写入数据
            For i = 1 To clsNum
                DoEvents
                If exitF = True Then
                    '检查是否取消
                    exl.DisplayAlerts = False
                    exl.Application.IgnoreRemoteRequests = False
                    exl.Quit
                    exl.DisplayAlerts = True
                    Set exl = Nothing
                    exitF = False
                    PuTongChaXun = False
                    Exit Function
                Else
                    For j = 0 To clsX - 1
                        '将数据写入变量数组
                        clsTable(j, i) = rs.Fields(j) & ""
                    Next
                    '显示写入进度
                    pgb.Value = i
                    '移动记录
                    rs.MoveNext
                End If
            Next
            '关闭数据集合
            rs.Close
            '关闭数据连接
            Data.closeCon
            
            '重置进度条
            pgb.Value = 0
            
            '将数据写入Excel表
            For i = 0 To clsNum
                DoEvents
                If exitF = True Then
                    '检查是否取消
                    exl.DisplayAlerts = False
                    exl.Application.IgnoreRemoteRequests = False
                    exl.Quit
                    exl.DisplayAlerts = True
                    Set exl = Nothing
                    exitF = False
                    PuTongChaXun = False
                    Exit Function
                Else
                    j = 0
                    For j = 0 To clsX - 1
                        '将数据写入表格
                        exl.Cells(i + 1, j + 1).Select
                        If IsDate(clsTable(j, i)) = True Then
                            exl.Selection.NumberFormatLocal = "@"
                        Else
                            exl.Selection.NumberFormatLocal = "G/通用格式"
                        End If
                        
                        exl.Cells(i + 1, j + 1) = clsTable(j, i)
                    Next
                    '显示写入进度
                    pgb.Value = i
                    labTiShi.Caption = "正在处理数据,请稍等...... " & clsNum - i
    
                End If
            Next
        
            '移动焦点
            exl.Range("A1").Select
            '显示生成的表格
            exl.Visible = True
            exl.Application.IgnoreRemoteRequests = False
            Set exl = Nothing
            strWhere = ""
            '清除数组
            Erase clsTable()
            PuTongChaXun = True
        End If
    
Exit Function
err1:
exl.DisplayAlerts = False
exl.Application.IgnoreRemoteRequests = False
exl.Quit
exl.DisplayAlerts = True
Set exl = Nothing
exitF = False
PuTongChaXun = False
End Function

Answer 13

这样速度是否太慢？
还有就是，如何将数据库中表的字段名也导出到EXCEL中。？？

Answer 14

字段放在数组里了
这样是比较慢
数据多的话不太好用'设置数组变量
            ReDim clsTable(clsX, clsNum)
            '将表头写入数组
            For i = 0 To clsX - 1
                clsTable(i, 0) = rs.Fields(i).Name
            Next