怎样把数据导到Excel表里？

[jilong4]

怎样把recordset里的数据导入到有固定格式的Excel里
Excel样式是预先设计好的

[cangwu_lee]

自己挑一下，意思应该是完整的。 有个别函数，你就重新写或者换成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

[zq972]

在程序中引用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 下运行通过。

[蔡健常熟]

'引用 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

[carfield2003]

http://blog.csdn.net/tt528/archive/2006/11/20/1398645.aspx

[ap0106204]

保存