此方法是借用Excel中QueryTables对象的Add方法实现数据的导出,将 ADO 或 DAO Recordset(记录集) 对象从指定区域的左上角开始创建新的查询表,导出数据到Excel时带有标题。
关于此对象的add方法的使用我写了一个专门的函数,可以直接调用便于数据导出至Excel,调用方法如下:
ExportToExcelQueryTables "Products", "select [Supplier IDs],ID,[Product Code],[Product Name],[Description] from Products"
"Products" 就指工作薄的名称。
"select [Supplier IDs],ID,[Product Code],[Product Name],[Description] from Products" 是需要导出数据的SQL语句。
函数如下:
'===============================================================================
'函数名称: ExportToExcelQueryTables
'功能描述: 将SQL语句创建的记录集对象中的内容复制到Excel工作表
'输入参数: WorkbookName 必需的,工作簿名称
' strSQL 必需的,不能包含具有 OLE 对象的字段,否则该方法无效。
'返回参数: 无
'使用说明: ExportToExcelQueryTables("公司资料","select * from 表名称或者查询名称")
'作 者: 金宇
'创建日期: 2013-11-1
'===============================================================================
Function ExportToExcelQueryTables(ByVal WorkbookName As String, ByVal strSQL As String)
On Error GoTo Err_ExportToExcel
Dim objExcel As Object
Dim objBook As Object
Dim objSheet As Object
Dim objRange As Object
Dim objExcelQuery As Object
Dim rst As Object
Dim cnn As Object
Dim strFileName As String
Dim strExtName As String
Dim lngRow As Long
Dim lngColumn As Long
Dim FirstRange As String
If Dir(WorkbookName) <> "" Then Kill WorkbookName
'根据当前版本取得对应的文件扩展名
strExtName = ".xls"
If Val(Application.Version) > 11 Then strExtName = ".xlsx"
'取得另存为文件名
With Application.FileDialog(2) 'msoFileDialogSaveAs
.InitialFileName = WorkbookName & strExtName
If Not .Show Then Exit Function
strFileName = .SelectedItems(1)
If Not strFileName Like "*" & strExtName Then
strFileName = strFileName & strExtName
End If
If Len(Dir(strFileName)) > 0 Then Kill strFileName
End With
DoCmd.Hourglass True
'ADO方式
Set rst = CreateObject("adodb.recordset")
Set cnn = CurrentProject.Connection
'CursorLocation = 3 这段代码必须加否则会出错,
'如果不加会在objSheet.QueryTables.Add那里会出现 "无效的过程调用或参数"
rst.CursorLocation = 3
rst.Open strSQL, cnn, 1, 1
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
Set objBook = objExcel.Workbooks.Add
Set objSheet = objBook.Worksheets.Add
'Set objSheet = objBook.Worksheets("Sheet1")
objSheet.Name = WorkbookName '工作表名称
objSheet.Select
Set objExcelQuery = objSheet.QueryTables.Add(rst, objSheet.Range("A1"))
With objExcelQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
objExcel.Visible = True
objBook.SaveAs strFileName
Exit_ExportToExcel:
Set rst = Nothing
Set objSheet = Nothing
Set objBook = Nothing
Set objExcel = Nothing
DoCmd.Hourglass False
Exit Function
Err_ExportToExcel:
MsgBox Err.Description, vbCritical, "错误提示"
Resume Exit_ExportToExcel
End Function
测试示例下载:
点击下载此附件