写了一段程序,导数据到EXCEL,速度很快的,大家分享

[lihonggen0]

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
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True

Rs_Data.Open strOpen, adoCN, adOpenStatic, adLockOptimistic
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
IrowCount = .RecordCount
'字段总数
IcolCount = .Fields.Count
End With
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

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

xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

End Function

[lihonggen0]

好久没上CSDN了，顺便将以前的程序更正一下，速度提高了许多许多




Private Sub Command1_Click()
Dim Irow, Icol As Integer
Dim IrowCount, IcolCount As Integer
Dim Fieldlen1 As Integer
'存字段长度值
Dim Fieldlen()
'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)
Dim strSource, strDestination As String
strDestination = App.path & "\Excels\TempExcel.xls"

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
xlApp.Workbooks.Open (strDestination)
Set xlBook = xlApp.Workbooks(1)
Set xlSheet = xlBook.Worksheets("sheet1")

xlApp.ScreenUpdating = False 'On Error GoTo excle
With Rs_temp

If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If

'记录总数
IrowCount = .RecordCount
'字段总数
IcolCount = .Fields.Count

ReDim Fieldlen(IcolCount)
.MoveFirst
For Irow = 1 To IrowCount + 1

For Icol = 1 To IcolCount
Select Case Irow
'在Excel中的第一行加标题
Case 1
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
'将数组FIELDLEN()存为第一条记录的字段长
Case 2
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
'如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If

xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
'Excel列宽等于字段长
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
'向Excel的CellS中写入字段值
Case Else
If IsNull(.Fields(Icol - 1)) Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
Else
Fieldlen1 = LenB(.Fields(Icol - 1))
End If

If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'表格列宽等于较长字段长
Fieldlen(Icol) = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'数组Fieldlen(Icol)中存放最大字段长度值
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If

xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next

If Irow <> 1 Then
If Not .EOF Then .MoveNext
End If

Next
xlSheet.Columns(1).ColumnWidth = 15
xlSheet.Columns(2).ColumnWidth = 15
xlSheet.Columns(3).ColumnWidth = 15
xlSheet.Columns(4).ColumnWidth = 15
xlSheet.Columns(5).ColumnWidth = 15

'网格线
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).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

'显示表格
' Dim ExclFileName As String
' ExclFileName = App.path & "\公司人员情况表.xls"
' If Dir(ExclFileName) <> "" Then
' Kill ExclFileName
' End If
' xlSheet.SaveAs (ExclFileName)
xlApp.Application.Visible = True
xlApp.ScreenUpdating = True '交还控制给Excel
' xlsheet.PrintPreview
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
' xlApp.Quit
End With
'excle:
' MsgBox ("您没有安装 Excle2000，请先安装 Excel2000 ！")

End Sub

[gyang]

up

[kingbear2000]

大哥，不错吗？在3个月前，小弟，几经周折，终于也成功。方法与大哥差不够，用query队列，通过内存来复制。但小弟，有一个问题也想请教一下：
请问在其他数据源中能否实现如： access,txt

[lihonggen0]

没问题，用ADO打开Access 表，




如果是TXT，可以先转化为Access


Text 转换为 Access MDB
Text 文件类型在很多软件中都为一般应用程序与数据库之间架起一座桥梁。你可以使用 Text ISAM 驱动程序和 SQL 来把 Text 文件转换成 Access MDB 数据库文件，首先，为文本文件创建一个 SCHEMA.INI 文件。然后，你可以使用下面的代码来实现转换：


Dim db As Database, tbl as TableDef

Set db = DBEngine.CreateDatabase(App.Path & "\mymdb.mdb", dbLangGeneral, dbVersion_0)

Set tbl = db.CreateTableDef("Temp")

tbl.Connect = "Text;database=c:\vbpj\data"

tbl.SourceTableName = "Customer#txt"

db.TableDefs.Append tbl

db.Execute "Select Temp.* into NewTable from Temp"

db.TableDefs.Delete tbl.Name

db.Close

Set tbl = Nothing

Set db = Nothing

[TT008]

又有好东西
收下了

[silverstone]

等等，我有类似的东西。

[lihonggen0]

===========================
以下写CELL的方法速度奇慢无比
===========================

用VB控制EXCEL生成报表
做为一种简捷、系统的 Windows应用程序开发工具，Visual Basic 5 具有强大的数据处理功能，提供了多种数据访问方法，可以方便地存取Microsoft SQL Server、Oracle、XBase等多种数据库，被广泛应用于建立各种信息管理系统。但是，VB缺乏足够的、符合中文习惯的数据表格输出功能，虽然使用Crystal Report控件及 Crystal Reports程序可以输出报表，但操作起来很麻烦，中文处理能力也不理想。Excel作为Micorsoft公司的表格处理软件在表格方面有着强大的功能，我们可用VB5编写直接控制Excel操作的程序,方法是用VB的OLE自动化技术获取Excel 97 的控制句柄,从而直接控制Excel 97的一系列操作。

下面给出一个实例：

首先建立一个窗体（FORM1）在窗体中加入一个DATA控件和一按钮，

引用Microsoft Excel类型库:

从"工程"菜单中选择"引用"栏;

选择Microsoft Excel 8.0 Object Library;

选择"确定"。

在FORM的LOAD事件中加入：
　　Data1.DatabaseName = 数据库名称
　　Data1.RecordSource = 表名
　　Data1.Refresh

在按钮的CLICK事件中加入
　　Dim Irow, Icol As Integer
　　Dim Irowcount, Icolcount As Integer
　　Dim Fieldlen() "存字段长度值
　　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 Data1.Recordset
　　.MoveLast

　　If .RecordCount < 1 Then
　　　　MsgBox ("Error 没有记录!")
　　　　Exit Sub
　　End If

　　Irowcount = .RecordCount "记录总数
　　Icolcount = .Fields.Count "字段总数

　　ReDim Fieldlen(Icolcount)
　　.MoveFirst

8

　　For Irow = 1 To Irowcount + 1
　　　For Icol = 1 To Icolcount
　　Select Case Irow
　　Case 1 "在Excel中的第一行加标题
　　xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
　　Case 2 "将数组FIELDLEN()存为第一条记录的字段长

　　If IsNull(.Fields(Icol - 1)) = True Then
　　　　Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
　　　　　"如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
　　Else
　　　　Fieldlen(Icol) = LenB(.Fields(Icol - 1))
　　End If

　　xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
　　　"Excel列宽等于字段长
　　xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
　　　"向Excel的CellS中写入字段值
　　Case Else
　　Fieldlen1 = LenB(.Fields(Icol - 1))

　　If Fieldlen(Icol) < Fieldlen1 Then
　　xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
　　　"表格列宽等于较长字段长
　　Fieldlen(Icol) = Fieldlen1
　　　"数组Fieldlen(Icol)中存放最大字段长度值
　　Else
　　　xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
　　End If

　　xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
　　End Select
　　Next
　　If Irow <> 1 Then
　　If Not .EOF Then .MoveNext
　　End If
　　Next
　　With xlSheet
　　.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
　　　"设标题为黑体字
　　.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
　　　"标题字体加粗
　　.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
　　　"设表格边框样式
　　End With
　　xlApp.Visible = True "显示表格
　　xlBook.Save "保存
　　Set xlApp = Nothing "交还控制给Excel
　　End With

本程序在中文Windows98、中文VB5下通过。

[lihonggen0]

select case 部分执行时间太长,如果有一万条记录,一分钟处理时间

[silverstone]

这个程序让用户输入odbc数据源名称，然后把此数据源中的所有数据导倒excel，每个表一张sheet。不过好想与你的程序有区别，我是循环向每个cell赋值，这样是不是太慢了，用它导sql server的northwind数据库，可能导了5分钟，当然我这台机子是mmx166的.

Option Explicit
Private Sub Command1_Click()
Dim cnnstring As String
Dim cnn As New ADODB.Connection
Dim stable, rs As New ADODB.Recordset
Dim sfilename As String
Dim nrecord, srecord, stmpfield As String
Dim ssql As String
Dim k, m, ifile, p As Integer
Dim xlapp As New Excel.Application
Dim xlbook As New Excel.Workbook
Dim xlsheet As New Excel.Worksheet

If Text1.Text = "" Then
MsgBox "请输入odbc数据源"
Exit Sub
End If

If Dir("C:\Documents and Settings\Administrator\桌面" + "\ConvertFiles", vbDirectory) = "" Then
MkDir "C:\Documents and Settings\Administrator\桌面" + "\ConvertFiles" 'mkdir app.path+"\convertfiles"
End If
ChDir "C:\Documents and Settings\Administrator\桌面\ConvertFiles"
'如果没有converfiles文件夹,则建立此文件夹,默认为桌面

cnnstring = "PROVIDER=MSDASQL;dsn=" & Text1.Text & ";uid=sa;pwd=;"
cnn.CursorLocation = adUseClient
cnn.Open cnnstring
Set stable = cnn.OpenSchema(adSchemaTables)
stable.MoveFirst
Set xlbook = xlapp.Workbooks.Add

Do Until stable.EOF
If stable!TABLE_TYPE = "TABLE" Then
ssql = "select * from [" & stable!table_name & "]"
Set rs = cnn.Execute(ssql)
Set xlsheet = xlbook.Worksheets.Add
xlsheet.Name = stable!table_name
For k = 0 To rs.Fields.Count - 1
xlsheet.Cells(1, k + 1).Value = rs.Fields(k).Name
Next k '付字段名
For k = 0 To rs.RecordCount - 1
For m = 0 To rs.Fields.Count - 1
If rs.Fields(m).Type = "205" Then
xlsheet.Cells(k + 2, m + 1).Value = "图形"
Else
xlsheet.Cells(k + 2, m + 1).Value = rs.Fields(m).Value
End If
Next m
rs.MoveNext
Next k '付字段值
stable.MoveNext
Else
stable.MoveNext
End If
Loop
xlsheet.SaveAs "C:\Documents and Settings\Administrator\桌面\ConvertFiles\" & Text1.Text & ".xls"

MsgBox "导出完成"
xlapp.Quit
Set xlsheet = Nothing
Set xlbook = Nothing
End Sub

[lihonggen0]

===========================
写CELL的方法速度奇慢无比
===========================

[silverstone]

那QueryTables是个什么东东，介绍一下，或哪里有介绍。

[shanhx]

不错，不错绝对算的上经典，不过速度还不是最佳！！！比起那个什么"东方不败"要强多了，那个只是凭着一点api的经验，到处阴阳怪气的换马甲，看不贯。

[lihonggen0]

导入文本文件

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Documents and Settings\BC\My Documents\刘燕然\d.txt", Destination:= _
Range("E2"))
.Name = "d"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.Refresh BackgroundQuery:=False
End With
ActiveWindow.ScrollRow = 42

[silverstone]

up

[silverstone]

我把我的程序改成你的样子了，速度变得奇快，非常感谢，同时，我始终对 Excel.QueryTable 不是很了解，程序改成这样后，怎样才能对查询所得的字段进行操作，比如刚才我的程序里面逐个向cell赋值，就可以屏蔽掉数据格式为image的字段，那么现在呢？

[lihonggen0]

执行完后在下面写给单元格赋值

xlSheet.Cells(1, 3) = "报表标题"