怎样把数据导到Excel表里?

jilong4 2006-12-15 03:30:50
怎样把recordset里的数据导入到有固定格式的Excel里
Excel样式是预先设计好的
...全文
239 5 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
5 条回复
切换为时间正序
请发表友善的回复…
发表回复
ap0106204 2006-12-15
  • 打赏
  • 举报
回复
保存
carfield2003 2006-12-15
  • 打赏
  • 举报
回复
http://blog.csdn.net/tt528/archive/2006/11/20/1398645.aspx
蔡健常熟 2006-12-15
  • 打赏
  • 举报
回复

'引用 microsoft excel 9.0 object library 以上版本
'调用 call ExportToExcel(adodc1.recordset,"表格名称")或call ExportToExcel(ADODB.Recordset,"表格名称")
'如果是ADODB.Recordset 传递数据集,需要使用用户游标 rs.CursorLocation = adUseClient

Public Function ExportToExcel(Rs_Data As ADODB.Recordset, Titles_Name)
On Error GoTo ERRCL
Dim Irowcount As Long
Dim Icolcount As Long

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable

' 假设rs_data是你的记录集
If Rs_Data.RecordCount < 1 Then
MsgBox "没有可导出的记录!", vbInformation + vbOKOnly, "提示"
Exit Function
End If
'记录总数
Irowcount = Rs_Data.RecordCount
'字段总数
Icolcount = Rs_Data.Fields.Count



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("a2"))
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 8)).Merge
xlSheet.Cells(1, 1).HorizontalAlignment = xlCenter
xlSheet.Cells(1, 1) = Titles_Name
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(2, 1), .Cells(Irowcount + 2, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式

' .PageSetup.PaperSize = xlPaperA4 '
' .PageSetup.PrintGridlines = True
End With
xlApp.Application.Visible = True


Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Function
ERRCL: MsgBox "无有效数据或 Excel 2000 未安装!", vbInformation, "错误"
End Function
zq972 2006-12-15
  • 打赏
  • 举报
回复
在程序中引用Microsoft Excel 9.0 Object Library,将下文加入到一个模块中,窗体中调用如下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 = Nothing
End Function

注::在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000
本程序在Windows 98/2000,VB 6 下运行通过。
cangwu_lee 2006-12-15
  • 打赏
  • 举报
回复
自己挑一下,意思应该是完整的。 有个别函数,你就重新写或者换成VB自带的函数。


Public Sub doExport(ByVal caption As String, ByVal text As String, ByVal MsgHwnd As Long, _
ByVal grid As DataGrid, _
ByVal rs As ADODB.Recordset)
If UCase(TypeName(rs)) = "Nothing" Then
Exit Sub
End If

If rs.Fields.Count = 0 Or grid.Columns.Count = 0 Then
Exit Sub
End If

Dim Fn As String

Fn = FileDialog.SaveDialog(MsgHwnd)
If Fn = "" Then Exit Sub
If Not EndWith(Fn, ".xls") Then Fn = Fn & ".xls"

Dim xls As Excel.Application
Dim w As Excel.Workbook
Dim e As Excel.Worksheet

Screen.MousePointer = 11
On Error Resume Next
Set xls = CreateObject("Excel.Application")
If Err.Number <> 0 Then
MsgBox "Sorry, create Excel object exception. Please check if Excel installed."
Exit Sub
End If
On Error GoTo 0
xls.Visible = True
If fileExists(Fn) Then
Set w = xls.Workbooks.Open(Fn)
Else
Set w = xls.Workbooks.Add()
End If

Set e = w.Worksheets.Add()

Dim line As Long, iP As Integer
line = 1

If caption <> "" Then
e.cells(line, grid.Columns.Count / 2) = caption
line=line+1
End If

If text <> "" Then
If grid.Columns.Count > 2 Then
e.cells(line, CInt(grid.Columns.Count / 2) - 1) = text
Else
e.cells(line, grid.Columns.Count / 2) = text
End If
line=line+1
End If

For iP = 0 To grid.Columns.Count - 1
e.cells(line, 1 + iP) = grid.Columns(iP).caption
Next iP
Call inc(line)

If Not (rs.EOF And rs.BOF) Then
Dim bm As Long
bm = rs.Bookmark
rs.MoveFirst
Do While Not rs.EOF
e.cells(line, 1) = rs.Fields("PName").value
e.cells(line, 2) = rs.Fields("PAge").value
e.cells(line, 3) = rs.Fields("PGender").value
e.cells(line, 4) = rs.Fields("PPhone").value
e.cells(line, 5) = rs.Fields("PContent").value
e.cells(line, 6) = rs.Fields("FinishDT").value
e.cells(line, 7) = rs.Fields("FinishBy").value
e.cells(line, 8) = rs.Fields("PResult").value
e.cells(line, 9) = rs.Fields("Remark1").value
e.cells(line, 10) = rs.Fields("Remark2").value
line=line+1
rs.MoveNext
Loop
On Error Resume Next
rs.MoveFirst
If rs.Bookmark <> bm Then rs.Bookmark = bm
End If

e.Range("A1", "Z" & line).Columns.AutoFit
On Error GoTo 0

xls.DisplayAlerts = False
If fileExists(Fn) Then w.Save Else w.SaveAs Fn

w.Close
xls.Quit
Sleep 300

Set w = Nothing
Set xls = Nothing
Screen.MousePointer = 0
End Sub
数飞表单DIY平台,用户可以自定义出来包括crm、HR、OA等企业信息化办公系统,不用开发程序,不用懂技术,轻轻松松完成企业信息化平台搭建。 1、表单管理: 表单引擎:表单引擎的核心功能:包括创建新的表单模块,表单权限,是否使用流程,编辑表单格式,增加表单字段,设置字段属性,设置表单中需要统计、汇总、导进导出的的字段,并生成为使用功能等操作。表单管理的大部分的操作在此完成。 支持表单对异常的自动检测功能。 选择管理:有些表单需要关联其他的数据表,比如通过选择部门、用户、或者数据分类等等。这种关联通过“选择管理”设置一种关联的规则,提供给表单管理中的编辑界面使用。 触发关联:通过某个字段的关联,自动从其他表里取出多个字段的内容,自动触发填充到新设计的表单中,我们称为“触发关联”。 扩展方法:有些表单需要实现一些复杂的逻辑业务,比如通过计算产品的进货数据和销售数据,得到产品的销售利润。这种复杂的逻辑计算我们用一个新的JAVA类或者JAVA方法实现,在数飞表单引擎中我们称为“扩展方法”,在表单管理中设置字段属性的时候,可以指定具体字段跟具体的扩展方法关联。 2、工作流 分类管理:设置流程的分类目录,支持树状结构,方便后期对流程过多情况查找,分析。 办理说明:对办理过程中的某一个办理人员动作的说明。比如审批、审核、签发等,方便设置流程的时候选择。配置流程模块时也可以直接输入办理名称。 流程模板:流程配置的核心部分:用户自定义流程的使用情况,是否指定的表单使用,节点办理过程,办理人员,办理权限,办理说明,字段权限,条件判断的操作。 3、系统管理 部门管理:设置企业的部门名称,录入时可以选择上级部门,形成直观的树状部门结构。部门可选择负责人员(相当于一个部门的最高领导,此设置一般用于流程) 职务管理:设置单位的职务名称,录入时按照职务大小等级,形成直观的职务上下级关系。 帐号管理:设置系统登陆用户帐号,录入时可选择默认的部门、职务。也可以同时录入该帐号的基本人事信息。 权限分配:在此设置系统管理员;设置各模块层次的管理员。上级模块管理员可管理下级模块。 模块管理:对模块名称、连接地址、权限级别的设置。也可以自行增加需要的模块连接、删除不需要的模块。系统提供将模块信息的导入、导出到excel功能。更新模块信息需要所有客户端刷新菜单。 即时信息:对系统中使用到的信息发布、内容提醒等工具,

7,785

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧