我最近看到一个把数据导入到EXCEL中的函数.这个函数能实现导出到EXCEL中,而且在导入后直接运行EXCEL.很方便.
我是想教一下:
如何将RECORDSET记录集的内容导出到EXCEL,但不启动EXCEL,而是存为一个指定的EXCEL文件,如:报表.XLS
最后有形成一个函数:exportEXCEL(strADOrecordset$,FILENAME$)
第一个参数为查询字符串,如"select * from table"
第二个参数为导出的文件名,如"xxx.XLS"如果给出这样的函数,或是给出提示.必给分.我要提高我的信誉分.呵呵.
有空交流可联系我：QQ-3433590
Excel 是一个非常优秀的报表制作软件，用VBA可以控制其生成优秀的报表，本文通过添加查询语句的方法，即用Excel中的获取外部数据的功能将数据很快地从一个查询语句中捕获到EXCEL中,比起往每个CELL里写数据的方法提高许多倍。将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
With xlSheet.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
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = NothingEnd Function
http://www.csdn.net/develop/author/netauthor/lihonggen0/SQL SERVER 与ACCESS、EXCEL的数据转换 （原创）
我的意思是不起动EXCEL程序,而是生成一个指定的文件,就是加一个参数,: filename as string 呵呵,能实现吗
... 'xlApp.Application.Visible = Truexlbook.SaveAs App.Path & "\" & filename & ".xls"
xlapp.close
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = NothingEnd Function
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))老是说实时错误“5”，无效的过程调用或参数？？
（rs_data有4条记录的，我引用的excel8.0的，不知道会不会有问题？？）还有问题二，明明使用了内部调用 Dim xlApp As New Excel.Application
为什么还要使用外部调用再建立对象啊？？
Set xlApp = CreateObject("Excel.Application")请教各位高手啊，我比较急用啊！！！！！！
引用Microsoft Excel类型库:从"工程"菜单中选择"引用"栏;选择Microsoft Excel 10.0 Object Library;选择"确定"。
---------------------------------------
to : trendvb(杨康)
看一下这个
http://www.csdn.net/develop/author/netauthor/lihonggen0/SQL SERVER 与ACCESS、EXCEL的数据转换 （原创）
--------------------------
to ： lly923(lly) (
'存字段长度值
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1) With Rs_Dzgl_Receipt
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If
xlSheet.Cells(1, 4).Value = .Fields("bt")
xlSheet.Cells(2, 1).Value = .Fields("invoice")
xlSheet.Cells(2, 9).Value = .Fields("packdate")
xlSheet.Cells(3, 1).Value = .Fields("")
'合并单元格
Dim nIcol As Integer
xlSheet.Range(xlSheet.Cells(3, 1), xlSheet.Cells(5, 9)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 9)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
'网格线
With xlSheet
.Range(.Cells(1, 1), .Cells(1, 9)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, 9)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(1, 9)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
'显示表格
Dim ExclFileName As String
ExclFileName = App.Path & "\箱单" & Text1(1).Text & ".xls"
If Dir(ExclFileName) <> "" Then
Kill ExclFileName
End If
xlSheet.SaveAs (ExclFileName)
xlApp.Application.Visible = True
'交还控制给Excel
xlSheet.PrintPreview
' xlApp.Application.Quit
' xlApp.Quit
End With
得一百分的,有解决方法吗