改良数据导出EXCEL时慢的程序

[aigozer]

现在导出2万多条到EXCEL时，要花20分钟时间，如何改良下

Dim i As Integer, r As Integer, c As Integer
Dim xlsRowCount As Integer, xlsColCount As Integer '生成的表格的行数和列数
Dim xlsApp As Excel.Application
Dim xlsBook As Excel.Workbook
Dim xlsSheet As Excel.Worksheet
Dim l, j As Long
Set xlsApp = CreateObject("Excel.Application")
Set xlsBook = xlsApp.Workbooks.Add
Set xlsSheet = xlsBook.Worksheets(1)
On Error Resume Next
xlsRowCount = MSHFlexGrid1.Rows
xlsColCount = MSHFlexGrid1.Cols
With xlsSheet
'设置电子表格各列的宽度
For l = 1 To xlsColCount - 1
Columns(i).ColumnWidth = 5 '每一个汉字大概占2的宽度（在默认的12号字的情况下）
Next
'设置电子表格各行的高度
For l = 1 To xlsRowCount - 1
.Rows(i).RowHeight = 18
Next
'把MSFlexGrid1的内容写入到电子表格中
For l = 0 To xlsRowCount - 1
For j = 0 To xlsColCount - 1
.Cells(l + 1, j + 1).Value = "'" & MSHFlexGrid1.TextMatrix(l, j + 1)
Next
Next
End With
xlsApp.Visible = True '显示电子表格

xlsBook.SaveAs App.Path & "\Excel文件\.xls" '保存，如果不指定保存路径及文件名，则默认存到“我的文档”下 Book1.xls
Set xlsApp = Nothing '交还控制给Excel
Set xlsApp = Quit

[vansoft]

一格格当然慢了.

你用记录集啊,
直接用EXCEL的方步,好象是copyrecordset,具体名字忘了.
你查一下吧.

以前用的,记不清了.

[波导终结者]

Public Sub ADOOutExcel(Excelrs As ADODB.Recordset, FilePath As String)
On Error GoTo Errshow
Dim intHeadCnt As Integer
Dim CloneRS As New ADODB.Recordset
Set CloneRS = Excelrs.Clone
CloneRS.Filter = Excelrs.Filter
'Create a Recordset from all the records in the Orders table
Dim sNWind As String
'Dim Excelconn As New ADODB.Connection
'Dim Excelrs As ADODB.Recordset
'sNWind = "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"
'Excelconn.Open "Provider=sqloledb.1;user ID=sa;password=sa;data source=(local);initial catalog=bookshop"
'Excelconn.CursorLocation = adUseClient
'Set Excelrs = Excelconn.Execute("Orders", , adCmdTable)

Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object

Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets(1)

For intHeadCnt = 0 To CloneRS.Fields.count - 1
oExcel.Worksheets(1).Cells(1, intHeadCnt + 1).value = CloneRS(intHeadCnt).Name
Next

oSheet.Range("A2").CopyFromRecordset CloneRS
'oExcel.Visible = True
'oExcel.Sheets.PrintPreview
oBook.SaveAs FilePath
oExcel.Quit
Set oExcel = Nothing
Set oBook = Nothing
Set oSheet = Nothing
Call MsgBox("文件" & FilePath & "导出成功！", vbInformation, "提示")

Exit Sub
'Excelrs.Close
'Excelconn.Close
Errshow:
MsgBox "不能创建xls文件，请确认已经安装Excel！"
End Sub