使用CopyFromRecordset语句,可以直接把记录集写入Excel工作表。 使用DAO的用意是支持Excel 97;如果使用ADO记录集,则仅支持Excel 2000。 下面是完整的例子:Dim db As dao.Database Dim rs As dao.Recordset Dim fd As dao.Field Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim cellCnt As Integer' Open the destination Excel workbook. Set xlApp = New Excel.Application Set xlBook = xlApp.Workbooks.add Set xlSheet = xlBook.ActiveSheetxlBook.PrintPreview ' Open the recordset. Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\bmkq.mdb") Set rs = db.OpenRecordset("SELECT ......") ' Title xlSheet.Cells(1, 1).Value = "考勤汇总表" ' Tabel Heads cellCnt = 1 For Each fd In rs.Fields Select Case fd.Type Case dbBinary, dbGUID, dbLongBinary, dbVarBinary ' This type of data can't export to excel Case Else xlSheet.Cells(2, cellCnt).Value = fd.Name xlSheet.Cells(2, cellCnt).Interior.ColorIndex = 33 xlSheet.Cells(2, cellCnt).Font.Bold = True xlSheet.Cells(2, cellCnt).BorderAround xlContinuous cellCnt = cellCnt + 1 End Select Next ' This is all it takes to copy the contents ' of the recordset into the first worksheet ' of Book1.xls. xlBook.Worksheets(1).Range("A3").CopyFromRecordset rs xlApp.ActiveWindow.DisplayZeros = False
xlBook.Worksheets(1).Range("A3").Select
xlApp.Visible = True ' Clean up everything. 'xlBook.Save 'xlBook.Close False 'xlApp.Quit rs.Close db.Close 'Set xlBook = Nothing 'Set xlApp = Nothing Set rs = Nothing Set db = Nothing exitsub:
Use Method CopyFromRecordset Example ------------------------ Private Sub cmdLoad_Click() Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim excel_app As Excel.Application Dim excel_sheet As Excel.Worksheet Screen.MousePointer = vbHourglass DoEvents ' Open the Access database. Set conn = New ADODB.Connection conn.ConnectionString = _ "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & txtAccessFile.Text conn.Open ' Select the Access data. Set rs = conn.Execute("Books") ' Create the Excel application. Set excel_app = CreateObject("Excel.Application") ' Uncomment this line to make Excel visible. ' excel_app.Visible = True ' Open the Excel workbook. excel_app.Workbooks.Open txtExcelFile.Text ' Check for later versions. If Val(excel_app.Application.Version) >= 8 Then Set excel_sheet = excel_app.ActiveSheet Else Set excel_sheet = excel_app End If ' Use the Recordset to fill the table. excel_sheet.Cells.CopyFromRecordset rs excel_sheet.Cells.Columns.AutoFit ' Save the workbook. excel_app.ActiveWorkbook.Save ' Shut down. excel_app.Quit rs.Close conn.Close Screen.MousePointer = vbDefault MsgBox "Ok" End Sub
使用DAO的用意是支持Excel 97;如果使用ADO记录集,则仅支持Excel 2000。
下面是完整的例子:Dim db As dao.Database
Dim rs As dao.Recordset
Dim fd As dao.Field
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim cellCnt As Integer' Open the destination Excel workbook.
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.add
Set xlSheet = xlBook.ActiveSheetxlBook.PrintPreview
' Open the recordset.
Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\bmkq.mdb")
Set rs = db.OpenRecordset("SELECT ......")
' Title
xlSheet.Cells(1, 1).Value = "考勤汇总表"
' Tabel Heads
cellCnt = 1
For Each fd In rs.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(2, cellCnt).Value = fd.Name
xlSheet.Cells(2, cellCnt).Interior.ColorIndex = 33
xlSheet.Cells(2, cellCnt).Font.Bold = True
xlSheet.Cells(2, cellCnt).BorderAround xlContinuous
cellCnt = cellCnt + 1
End Select
Next
' This is all it takes to copy the contents
' of the recordset into the first worksheet
' of Book1.xls.
xlBook.Worksheets(1).Range("A3").CopyFromRecordset rs
xlApp.ActiveWindow.DisplayZeros = False
xlBook.Worksheets(1).Range("A3").Select
xlApp.Visible = True
' Clean up everything.
'xlBook.Save
'xlBook.Close False
'xlApp.Quit
rs.Close
db.Close
'Set xlBook = Nothing
'Set xlApp = Nothing
Set rs = Nothing
Set db = Nothing
exitsub:
1:把你的记录查询语句复制到SQL查询分析器里,执行查询,得到结果
2:把得到的结果写如一个临时表里,
3:其实1,2可以放到一起写的。。右击这个临时表,选择所有任务,然后选择导出数据,进入导出数据向导,选择导出到EXCEL,里面有很多可以选择的。]
4:完成操作
Example
------------------------
Private Sub cmdLoad_Click()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim excel_app As Excel.Application
Dim excel_sheet As Excel.Worksheet Screen.MousePointer = vbHourglass
DoEvents ' Open the Access database.
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & txtAccessFile.Text
conn.Open ' Select the Access data.
Set rs = conn.Execute("Books") ' Create the Excel application.
Set excel_app = CreateObject("Excel.Application") ' Uncomment this line to make Excel visible.
' excel_app.Visible = True ' Open the Excel workbook.
excel_app.Workbooks.Open txtExcelFile.Text ' Check for later versions.
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If ' Use the Recordset to fill the table.
excel_sheet.Cells.CopyFromRecordset rs
excel_sheet.Cells.Columns.AutoFit ' Save the workbook.
excel_app.ActiveWorkbook.Save ' Shut down.
excel_app.Quit
rs.Close
conn.Close Screen.MousePointer = vbDefault
MsgBox "Ok"
End Sub