求助：vb保存数据到Excel中，有没有快速的方法！~

hataki · 发表于 2020-3-17 13:00:01

如题：
如果用普通的方法速度太慢了，有没有快速的方法将vb中德得到的数据保存到Excel文件中。在读取时我用了打开数据库的方法，速度上没问题，保存有没有类似的方法？我尝试了，但是保存的数据不是A1开始的,而且保存的数据不是数值型的，而是字符型的。望各位大虾不吝赐教！

giddens · 发表于 2020-6-25 22:15:01

Db.Execute "SELECT " & XsZd & " INTO [Excel 8.0;DATABASE=" & CMG.Filename & "].[dcxx] FROM [" & Bm & "]" & SQLWhere & SQLOrder

XsZd是指要显示的字段
CMG.filename指要保存到的文件名
dcxx是EXCEL中单元表的名称
Bm指数据库的表
sqlwhere指where条件
sqlorder指排序条件

这种方式快！

desperados · 发表于 2020-7-8 20:15:01

楼上的，楼主说不是从A1开始的，你这种方法应该不行吧

talent00168 · 发表于 2020-7-14 23:45:01

sheet1.[d10].copyfromrecordset rst

kidsex · 发表于 2020-7-16 01:45:01

偶写过的一个例子供楼主参考，这样的速度很快的！偶大概导出576*20的数据几秒就完事

强烈建议楼主使用导出表格文件比较好的方法是用CSV文件格式
它是一个格式化文本文件，大体格式为：文本行代表表格行
同一行以逗号分隔的内容表示不同字段的内容。

楼主可以将一个普通的EXCEL文件，选择另存为CSV格式后，用写字板打开这个文件看一看格式就知道了，非常简单的。并且这样做速度也很快，完全不是那种一格一格写数据可以比拟的。

在建立数据接口的时候可以建立一个字符串类型的数组，先将所有内容放在数组里，再用循环写入文件里。
几十万条记录的文件处理时间也不过几秒而已

补充一下：你生成的CSV文件，在装有OFFICE的系统上所显示的图标就是一个EXCEL的图标（稍微一点点不同，图标下面多了一个小写的"a"而已），说明OFFICE已经把这种文件注册为默认可打开的文件类型了。

需要仔细研究，学会并应用！！！！！！！！！！

Rem 快速保存的数据文件格式CSV，可以用EXCEL打开

Private Sub MnuCsv_Click()
Dim i As Integer

'窗体
Dim myPic As StdPicture
Set myPic = CapturePic(Picture1)
SavePicture myPic, "c:\myPic.bmp"

''写入CSV文件，EXCEL可以打开的文件

  Open "D:\11.csv" For Output As #1


      Print #1, " 步进序号"; ",";                         ''''' '这里是写CSV的第一行，固定的列头
   Print #1, "nx"; ",";
   Print #1, "αi"; ",";
   Print #1, "齿尖转动半径"; ",";
   Print #1, "Fc"; ",";
   Print #1, "Fh"; ",";
   Print #1, "Fdt"; ",";
   Print #1, "Fdn"; ",";
   Print #1, "Fo"; ",";
   Print #1, vbNullString                      ''''结束换行

''''''写入数据
For i = 1 To 546
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 0)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 1)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 2)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 3)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 4)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 5)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 6)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 7)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 8)); ",";
   Print #1, vbNullString
Next
Close #1

End Sub

打开保存文件方式：：
Rem 快速保存的数据文件格式CSV，可以用EXCEL打开

Private Sub MnuCsv_Click()
Dim i As Integer

'窗体
Dim myPic As StdPicture
Set myPic = CapturePic(Picture1)
SavePicture myPic, "c:\myPic.bmp"

''写入CSV文件，EXCEL可以打开的文件

Dim FileName As String                      '''''''''''将数据保存到Excel表里

CommDiag1.FileName = ""
CommDiag1.Filter = "CSV|*.csv"
CommDiag1.ShowSave
FileName = CommDiag1.FileName
If FileName = "" Then
  Exit Sub
End If

  Open FileName For Output As #1


   Print #1, " 步进序号"; ",";                         ''''' '这里是写CSV的第一行，固定的列头
   Print #1, "nx"; ",";
   Print #1, "αi"; ",";
   Print #1, "齿尖转动半径"; ",";
   Print #1, "Fc"; ",";
   Print #1, "Fh"; ",";
   Print #1, "Fdt"; ",";
   Print #1, "Fdn"; ",";
   Print #1, "Fo"; ",";
   Print #1, vbNullString                      ''''结束换行

''''''写入数据
For i = 1 To 546
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 0)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 1)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 2)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 3)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 4)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 5)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 6)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 7)); ",";
   Print #1, Val(MSFlexGrid1.TextMatrix(i, 8)); ",";
   Print #1, vbNullString
Next
Close #1

End Sub

hataki · 发表于 2020-7-25 21:30:01

kidsex
用你的方法的确比较快，不过现在又有个新问题，用这种方法保存的excel文件我用数据库方式打不开了，估计是文件格式不匹配，有没有什么方法与上面保存的方式相匹配的导出excel文件的方法呢？
传统方法很慢的，也应该是打开文件的方式吧！
请赐教!

kidsex · 发表于 2020-7-26 09:45:02

你说打不开CSV文件？是编写程序打开还是直接用access打开？说清楚点可以么？

传统的excel导出数据，目前没有搜索到别人有什么好的办法读取很快，因为其一般是一条一条数据读取的。但是目前excel和数据库连接也有成块的导入方式，不知你具体的方法是什么

hataki · 发表于 2020-7-26 22:45:01

下面这个方法是我找到的，也经过试验，速度确实挺快
Dim i As Integer
Dim mondata(1799) As Single
Dim adoConnection As New ADODB.Connection
Dim adoRecordset As New ADODB.Recordset

adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=D:\ttt.csv;Extended Properties='Excel 8.0;HDR=Yes'"
adoRecordset.Open "select * from [sheet1$]", adoConnection, adOpenKeyset, adLockOptimistic
Do Until adoRecordset.EOF
      mondata(i) = adoRecordset.Fields.Item(0).Value
      i = i + 1
   adoRecordset.MoveNext
Loop
'adoRecordset.Close
'adoConnection.Close
但是用你的方法保存后，运行上面的程序就报错，为：外部表不是预期的格式

这是传统的方法，速度太慢了点
Dim newXls As Excel.Application
Dim newBook As Excel.Workbook
Dim newSheet As Excel.Worksheet
Set newXls = CreateObject("Excel.Application")
Set newBook = newXls.Workbooks.Open(d:\ttt.csv) '打开已经存在的EXCEL工件簿文件
newXls.Visible = False '设置EXCEL对象可见（或不可见）
Set newSheet = newBook.Worksheets(command) '设置活动工作表
For i = 0 To 1799
      mondata(i) = Val(newSheet.Cells(i + 1, 1)) '给单元格（row,col）赋值
Next i
newBook.Application.Quit
Set newXls = Nothing

jcsexy · 发表于 2020-7-27 06:45:02

Private Sub Cmd_export_Click()
Dim strSql As String
Dim keycode As String

On Error GoTo err
If Trim(Cbo_date1.Text) = "" Or Trim(Cbo_date2.Text) = "" Then
MsgBox "请您选择导出的具体的结算日期!", vbOKOnly + vbExclamation, "警告"
Cbo_date1.SetFocus
End If

keycode = Trim(Cbo_date1.Text) & lpad(Trim(Cbo_date2.Text), 2, "0")

strSql = "SELECT * FROM t_monthtotal where total_no = '" & Trim(keycode) & "'"

ExportExcel (strSql)

fin: Exit Sub
err:
MsgBox "存在错误，请检查数据或是检查程序", vbOKOnly + vbExclamation, "警告"
Resume err

End Sub

'''---引用 Microsoft Excel 11.0 Object Library

Public Function ExportExcel(ByVal strSql As String)
   On Error GoTo err
   ' 定義 Excel 對象
   Dim priXLS    As Excel.Application
   Dim priWorkbook    As Excel.Workbook
   Dim priSheet    As Excel.Worksheet
   ' Rs 臨時記錄集
   Dim Rs    As New ADODB.Recordset
   Dim lngRow    As Long, lngRows    As Long, intField    As Integer, intFields    As Integer

   Screen.MousePointer = vbHourglass
   ' 打開記錄集﹐得到數據﹐將數據導入 Excel 表中

   Dim cnn As ADODB.Connection
   Set cnn = New ADODB.Connection
      cnn.Provider = "SQLOLEDB"
      cnn.Open ConnectString

   If Rs.State Then Rs.Close
   Rs.Open strSql, cnn, adOpenKeyset, adLockOptimistic
   If Rs.RecordCount = 0 Then GoTo err

   Set priXLS = New Excel.Application
   Set priWorkbook = priXLS.Workbooks.Add
   Set priSheet = priXLS.Sheets(1)
   With priSheet
      intFields = Rs.Fields.Count
      '''給字段標頭
      For intField = 1 To intFields
            .Cells(1, intField) = "'" & Rs(intField - 1).Name
      Next
      Rs.MoveLast
      lngCount = Rs.RecordCount
      Rs.MoveFirst
      '''給字段的值
      For lngID = 1 To lngCount
            For intField = 1 To intFields
               .Cells(lngID + 1, intField) = "'" & Rs(intField - 1).Value
            Next
            Rs.MoveNext
      Next
   End With
   priXLS.Visible = True
err:
   Screen.MousePointer = 0
End Function

jcsexy · 发表于 2020-7-27 08:15:01

Public Function ConnectString() _
As String
'returns a DB ConnectString
ConnectString = "Server=(local);Database=fin;Uid=sa;Pwd="
End Function

		自动登录	找回密码
密码			立即注册