1180
社区成员
- 主页
VB导出EXCEL问题,十万火急
小弟现使用VB,把STRING中的数据导出到EXCEL(STRING来源于SQL表，但是由于表中数据需要处理所以把表中内容读出再写如).现在使用CELL实现,但是速度很慢(40余字段,6K行).有没有更好的方法替代CELL?
再有,测试时使用TOP100条,可以正常输出,但是全部输出的时候却不能生成文件.为什么呢?(40余字段,6K行,其间需要对另一个13W条的数据库进行遍历从中取数据)
再有,测试时使用TOP100条,可以正常输出,但是全部输出的时候却不能生成文件.为什么呢?(40余字段,6K行,其间需要对另一个13W条的数据库进行遍历从中取数据)
...全文
请发表友善的回复…
发表回复
GGL123 2004-10-10
怎样将查询结果导出到Excel
http://www.luntan.com.cn/info/1963356728696149.htm
http://www.luntan.com.cn/info/1963356728696149.htm
GGL123 2004-10-10
Visual Basic 导出到 Excel
http://code365.com/html/vb/20040302/index/200432101819.html
http://code365.com/html/vb/20040302/index/200432101819.html
solo_mm7 2004-10-10
因为数据源的问题，我这个只能写行或者写格不能直接把显示的表转换。只能通过程序逐行或者格写，有没有好办法啊？
lujianyu1189 2004-10-10
我一般是使用mshflexgrid来显示要输出的数据,然后导出到EXECL就可以了,,好像还行..
老汉 2004-10-10
工程中需要加入对MicroSoft Excel9.0 Object Library(excel9.olb)库的引用。
下面的函数我在SQL2K+WIN2K+OFFICE2K中进行了测试，测试表中含带两位小数的数值型字段。
调用格式：
if ExportTOExcel("TestTable","TestExcel")=False then
msgbox "Error"
end if
' 将strTName表中的数据全部导入到strFName文件中
' 入参:strTName-所要导出的数据表名称
' strFName-接收数据到EXCEL文件名称
' (如果该文件已经存在，那么无条件的删除掉该文件后重新创建新的文件)
' (strFName为主文件名，扩展文件名以及路径均在本函数中给出)
' 返回:TRUE-导出成功，FALSE-导出不成功
'------------------------------------------------
Public Function ExportTOExcel(strTName As String, strFName As String) As Boolean
On Error GoTo ErrLiner
Dim strSql As String ' SQL语句临时变量
Dim strTemp As String
Dim objXLS As Object ' OLE自动化对象
Dim rsTemp As ADODB.Recordset ' 所要导出数据的容器记录集
Dim intHeadCnt As Integer ' 记录集的字段数
ExportTOExcel = False
' 检测文件是否存在，如果已经存在，那么KILL掉
strFName = "C:\" & strFName & ".xls"
If Dir(strFName) <> "" Then Kill strFName
' 构造要导出数据的记录集[这里没有判断结果集为空的情况]
strSql = "Select * From " & strTName
Set rsTemp = HisConn.Execute(strSql, 2)
' 创建EXCEL对象
Set objXLS = CreateObject("Excel.Sheet.8")
' EXCEL工作表名称定义为所导出的表名
objXLS.Worksheets(1).Name = strTName
' 利用记录集的字段名构造表头
For intHeadCnt = 0 To rsTemp.Fields.Count - 1
objXLS.Worksheets(1).Cells(1, intHeadCnt + 1).Value = rsTemp(intHeadCnt).Name
Next
' 第一行标题字体置为粗体
objXLS.Worksheets(1).Range(objXLS.Worksheets(1).Cells(1, 1), objXLS.Worksheets(1).Cells(1, rsTemp.Fields.Count)).Font.Bold = True
rsTemp.MoveFirst
' 向Excel文档输出数据[利用CopyFromRecordset属性来拷贝数据内容，有效的提高数据导出的速度]
'' objXLS.Worksheets(1).Cells.CopyFromRecordset rsTemp
objXLS.Worksheets(1).Range("A2").CopyFromRecordset rsTemp '保留了前面添加上去的第一行，从第二行开始进行数据复制
' EXCEL文档保存
objXLS.SaveAs strFName
' 注销对象空间
objXLS.Application.Quit: Set objXLS = Nothing: Set rsTemp = Nothing
'' ' 打开数据
'' If ChkAutoOpen.Value = 1 Then
''
'''' On Error Resume Next
'' '--------------------------------------------------------------------C:\Microsoft Office2000\Office
'' Shell "C:\Program Files\Microsoft Office\Office\excel.exe C:\" & strFName & ".xls", vbMaximizedFocus
'' Shell "D:\Program Files\Microsoft Office\Office\excel.exe C:\main1.xls", vbMaximizedFocus
'' Shell "C:\Microsoft Office2000\Office\excel.exe C:\" & strFName & ".xls", vbMaximizedFocus
'' End If
ExportTOExcel = True: Exit Function
ErrLiner:
Debug.Print Err.Description & Err.Number 'test
End Function
下面的函数我在SQL2K+WIN2K+OFFICE2K中进行了测试，测试表中含带两位小数的数值型字段。
调用格式：
if ExportTOExcel("TestTable","TestExcel")=False then
msgbox "Error"
end if
' 将strTName表中的数据全部导入到strFName文件中
' 入参:strTName-所要导出的数据表名称
' strFName-接收数据到EXCEL文件名称
' (如果该文件已经存在，那么无条件的删除掉该文件后重新创建新的文件)
' (strFName为主文件名，扩展文件名以及路径均在本函数中给出)
' 返回:TRUE-导出成功，FALSE-导出不成功
'------------------------------------------------
Public Function ExportTOExcel(strTName As String, strFName As String) As Boolean
On Error GoTo ErrLiner
Dim strSql As String ' SQL语句临时变量
Dim strTemp As String
Dim objXLS As Object ' OLE自动化对象
Dim rsTemp As ADODB.Recordset ' 所要导出数据的容器记录集
Dim intHeadCnt As Integer ' 记录集的字段数
ExportTOExcel = False
' 检测文件是否存在，如果已经存在，那么KILL掉
strFName = "C:\" & strFName & ".xls"
If Dir(strFName) <> "" Then Kill strFName
' 构造要导出数据的记录集[这里没有判断结果集为空的情况]
strSql = "Select * From " & strTName
Set rsTemp = HisConn.Execute(strSql, 2)
' 创建EXCEL对象
Set objXLS = CreateObject("Excel.Sheet.8")
' EXCEL工作表名称定义为所导出的表名
objXLS.Worksheets(1).Name = strTName
' 利用记录集的字段名构造表头
For intHeadCnt = 0 To rsTemp.Fields.Count - 1
objXLS.Worksheets(1).Cells(1, intHeadCnt + 1).Value = rsTemp(intHeadCnt).Name
Next
' 第一行标题字体置为粗体
objXLS.Worksheets(1).Range(objXLS.Worksheets(1).Cells(1, 1), objXLS.Worksheets(1).Cells(1, rsTemp.Fields.Count)).Font.Bold = True
rsTemp.MoveFirst
' 向Excel文档输出数据[利用CopyFromRecordset属性来拷贝数据内容，有效的提高数据导出的速度]
'' objXLS.Worksheets(1).Cells.CopyFromRecordset rsTemp
objXLS.Worksheets(1).Range("A2").CopyFromRecordset rsTemp '保留了前面添加上去的第一行，从第二行开始进行数据复制
' EXCEL文档保存
objXLS.SaveAs strFName
' 注销对象空间
objXLS.Application.Quit: Set objXLS = Nothing: Set rsTemp = Nothing
'' ' 打开数据
'' If ChkAutoOpen.Value = 1 Then
''
'''' On Error Resume Next
'' '--------------------------------------------------------------------C:\Microsoft Office2000\Office
'' Shell "C:\Program Files\Microsoft Office\Office\excel.exe C:\" & strFName & ".xls", vbMaximizedFocus
'' Shell "D:\Program Files\Microsoft Office\Office\excel.exe C:\main1.xls", vbMaximizedFocus
'' Shell "C:\Microsoft Office2000\Office\excel.exe C:\" & strFName & ".xls", vbMaximizedFocus
'' End If
ExportTOExcel = True: Exit Function
ErrLiner:
Debug.Print Err.Description & Err.Number 'test
End Function