请教：数据导出到Excel的速度问题

[老田低代码]

在将数据写入Excel之前我们首先要建立Excel对象，然后导出，但是这个过程实在是比较漫长。
但是有些列表控件自带的导出方法速度非常快，比如spread6这些控件，其导出时间简直还不够我们使用常规的Createobject("Excel.Application")所用的时间呢！
请教各位：是不是可以有什么方法可以提高速度？这些控件是怎么样实现这么快的速度的呢？

[老田低代码]

谢谢！这个问题的确是可以，但是如果我的数据本来就在一个列表控件中，那么且不是没有办法了，因为我的列表控件中的数据可能还有其他比较个性化的地方，不是简单的使用语句读进去的。

[老田低代码]

其实我最希望知道那些控件（比如spread这种）是使用什么方法的，因为单独这样创建一个Excel对象也要好几秒中Createobject("Excel.Application")，而他们的导出时间往往就是2秒种（如果数据量不是太多的情况下）

[viena]

内部运行机制不知道，但估计是比较底层一点的OLE控制了，不是简单使用封装好的整个对象

就像ADODB对象封装了OLE DB的具体实现，使用简单方便，也可以直接用OLE DB编程，但OLE DB本身是很复杂的东西

[viena]

VB6 中将数据导出到 Excel 提速之法

李洪根
--------------------------------------------------------------------------------

Excel 是一个非常优秀的报表制作软件，用VBA可以控制其生成优秀的报表，本文通过添加查询语句的方法，即用Excel中的获取外部数据的功能将数据很快地从一个查询语句中捕获到EXCEL中，比起往每个CELL里写数据的方法提高许多倍。
在程序中引用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

[myhgyp]

把李洪根的方法想办法改一下不行吗？

[cindytsai]

绝!但是可以怎么改呢?

[老田低代码]

主要是不知道他们怎么创建Excel.Application 对象的，好象单独创建这个对象的时间就比他们导出到Excel的时间还要长，所以如果能够不创建对象或者其他方法就好了。

[aohan]

将其改了一下,封成一个DLL,
类名 : ExportToExcel
class: ToExcel

Option Explicit
Dim Adoconn As New ADODB.Connection '定义ADO连接
Public Function QueryToExcel(ByVal Strcnn As ADODB.Connection, ByVal StrOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'* 注:须在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Long
Dim Icolcount As Long
Dim xlApp As New Excel.Application '定义Excel对象
Dim xlBook As Excel.Workbook '定义工作薄
Dim xlSheet As Excel.Worksheet '定义工作表
Dim xlQuery As Excel.QueryTable
On Error GoTo err:
If Adoconn.State = 1 Then Adoconn.Close
Set Adoconn = Strcnn
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Adoconn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = StrOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox "没有找到指定的记录！", vbInformation, "查询"
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
Exit Function
err:
MsgBox err.Description

End Function

然后生成一个DLL

[aohan]

程序中调用时

先引用ExportToExcel
Option Explicit
Dim DBToExcel As ExportToExcel.ToExcel
Dim Adoconn As New ADODB.Connection

Private Sub Command1_Click()
Set DBToExcel = New ExportToExcel.ToExcel
Dim StrSql As String
StrSql = "select * from Customers"

'StrSql ="select companyname as 公司名,contactname as 联系人 from Customers" '测试2
DBToExcel.QueryToExcel Adoconn, StrSql
Set DBToExcel = Nothing
End Sub
Private Sub Form_Load()
Dim StrConnect As String
StrConnect = "driver={sql server};server=127.0.0.1;uid=SA;pwd=;database=NorthWind"
Adoconn.ConnectionString = StrConnect
Adoconn.Open
End Sub