vb导出速度问题

[amanloveyou]

现做一报表，每个表的数据有300多万条，生成报表后也是很多条记录，我的导出方法是逐记录的导出到execl中，但是这样的速度很慢，有更好的方法吗？提高速度的，求导出速度快的方法，多多给分，万分感谢！在线急等！有现成的方法代码，不省感激!！！！

[wxrwan]

SELECT * INTO [Excel 8.0;DATABASE=C:\AAA.XLS].[WorkSheet1] FROM TABLE1

[faysky2]

300多万条,得分成差不多100个Sheet表吧?

[amanloveyou]

也不是了，最中找到的每天的有几百条吧，每个月就几千条记录，但是为什么用我的导出方法太慢了，有更好的方法代码吗？谢谢。

[amanloveyou]

Set objExlBok = objExlApp.Workbooks.Add
Set objExlSht = objExlBok.Sheets(1)
With aa
For i = 0 To aa.Rows - 1
For j = 0 To aa.Cols - 1
objExlSht.Cells(i + 1, j + 1) = .TextMatrix(i, j)
Next j
ccrpProbar.Value = i
Next i
End With
这样很慢的，有更好更快的方法吗？谢谢。

[faysky2]

试试 CopyFromRecordset 方法:

rst.Open "select * from table1 where ......", conn, adOpenKeyset, adLockOptimistic

Dim xls As New Excel.Application
Dim book As New Excel.Workbook
Set book = e.Workbooks.Open("c:\test.xls")
xls.Visible = True
book.Sheets(1).Range(s.Cells(1, 1), s.Cells(1, 1)).CopyFromRecordset rst

[amanloveyou]

不太明白，能不能给个已经验证了的代码呢？谢谢。现在急的真不知道怎么办了。

[faysky2]

objExlSht.Cells(i + 1, j + 1) = .TextMatrix(i, j)
---------------
你是把MSFlexGrid或MSHFlexGrid里的数据导出到Excel去吧,而MSFlexGrid或MSHFlexGrid里的数据就是记录集的数据,所以你可以用 CopyFromRecordset 方法,直接把记录集的数据导到Excel里(以Access为例):

Private Sub Command1_Click()

Dim conn As New ADODB.Connection
Dim rst As New ADODB.Recordset
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\test.mdb;Persist Security Info=False"
rst.Open "select * from table1", conn, adOpenKeyset, adLockOptimistic

Dim xls As New Excel.Application
Dim book As New Excel.Workbook
Dim sheet As New Excel.Worksheet
Set book = xls.Workbooks.Open("c:\test.xls")
Set sheet = book.Sheets(1)
sheet.Range(sheet.Cells(1, 1), sheet.Cells(1, 1)).CopyFromRecordset rst
xls.Visible = True
'......
End Sub

[amanloveyou]

我的报表字段多于255个，也就是说导出的时候在execl表中用到sheet（1）的同时，还的利用sheet（2），现在数据都在flexgrid控件中显示的， 我的数据库为sql，

[flfq]

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 = g_strDbConn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox "数据库中没有查询到符合条件的记录!", vbExclamation, App.Title
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


xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

End Function

[faysky2]

那可以分两次查询和插入,例如:

rst.Open "select c1,c2,c3,...,c255 from table1", conn, adOpenKeyset, adLockOptimistic

Dim xls As New Excel.Application
Dim book As New Excel.Workbook
Dim sheet As New Excel.Worksheet
Set book = xls.Workbooks.Open("c:\test.xls")
Set sheet = book.Sheets(1)
sheet.Range(sheet.Cells(1, 1), sheet.Cells(1, 1)).CopyFromRecordset rst

rst.Close
rst.Open "select c256,c257,... from table1", conn, adOpenKeyset, adLockOptimistic
Set sheet = book.Sheets(2)
sheet.Range(sheet.Cells(1, 1), sheet.Cells(1, 1)).CopyFromRecordset rst

是sql库也没关系,改一下数据库的连接就可以了