求助：vb如何将access当前查的数据导出为excel - 编程论坛

#2

事业男儿2020-08-22 10:28

求各位路过的老师帮帮忙看一下，谢谢！

#3

事业男儿2020-08-23 20:36

在网上找到一个导出ListView1显示的数据到excel上，粘贴了导出为excel的相关代码到以及添加了他的modExcel模块，也引用了相关事项，但是没有成功，modExcel模块的xlApp As New Excel.Application这行代码总是报错

只有本站会员才能查看附件，请登录

，哎依葫芦画瓢都没有搞定

，求各位版主帮个忙，谢谢！

只有本站会员才能查看附件，请登录

[此贴子已经被作者于2020-8-23 20:41编辑过]

#4

foreach2020-08-24 23:56

能将数据写入到数组中，再把数据输出到Excel中即可

#5

cwa99582020-08-25 11:17

你先做个excel模板，在第一行输入ListView1的表头。
然后把ListView1力的数据输入到这个excel文件里。

程序代码：

Private Sub Command7_Click()
    Dim Conn1 As New ADODB.Connection
    Dim Rs1 As New ADODB.Recordset
    'On Error GoTo ErrDlog
    Dim sql1 As String, cnStr1 As String
    Dim exPath As String, Biao As String

    exPath = App.Path & "\Exc.xls"  'excel文件名称
    cnStr1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & exPath & ";Persist Security Info=False;Extended Properties='Excel 8.0;HDR=Yes'"
    Biao = "123"   '表名称
    Conn1.Open cnStr1
    sql1 = "select * from [" & Biao & "$]"
    Rs1.Open sql1, Conn1, adOpenStatic, adLockOptimistic

    For i = 1 To ListView1.ListItems.Count
        Rs1.AddNew
        Rs1.Fields(0) = ListView1.ListItems(i).Text
        Rs1.Fields(1) = ListView1.ListItems(i).SubItems(1)
        Rs1.Fields(2) = ListView1.ListItems(i).SubItems(2)
        Rs1.Fields(3) = ListView1.ListItems(i).SubItems(3)
        Rs1.Fields(4) = ListView1.ListItems(i).SubItems(4)
        Rs1.Fields(5) = ListView1.ListItems(i).SubItems(5)
        Rs1.Update

    Next

    MsgBox "数据导出完成！", , "提示"
    Rs1.Close
    Conn1.Close

End Sub

#6

cwa99582020-08-25 11:26

如果你对excel对象熟悉，也可以用excel对象，直接把数据写到excel文件里，不过也要先建立一个excel文件。
或者直接写到csv文件里，实际上就是文本文件，用逗号,作为分隔符。这个可以直接用excel打开的。

程序代码：

Private Sub Command8_Click()
    Dim Exlpath As String

    Exlpath = App.Path & "\exl.csv"
    Open Exlpath For Output As #1
    Print #1, "流水单号,姓名,金额,村组,金额类型,填表日期"

    For i = 1 To ListView1.ListItems.Count

        Print #1, ListView1.ListItems(i).Text & "," & ListView1.ListItems(i).SubItems(1) & "," & ListView1.ListItems(i).SubItems(2) & "," & ListView1.ListItems(i).SubItems(3) & "," & ListView1.ListItems(i).SubItems(4) & "," & ListView1.ListItems(i).SubItems(5)

    Next
    Close #1
    MsgBox "数据导出完成！", , "提示"
End Sub

[此贴子已经被作者于2020-8-25 12:06编辑过]

#7

事业男儿2020-08-25 17:30

回复 5楼 cwa9958

首先谢谢cwa9958版主，以及楼上的其他热心的朋友：
1、我做了这个收人情的软件，在收礼的时候用笔记本现场收，办完酒后就把数据导出来发给我哥哥，弟弟他们看，以便知道那些人来送了礼的送多少钱。彻底改变传统的纸质记录，纸质的不好保存。
2、目前智能手机已经普及，这个数据可以发给哥哥、弟弟他们看了，也可以在微信上收藏，或者发朋友圈保存（个人能见），农村也实现无纸化办公，如果需要纸质的账单，也可以到街上去打印出来

cwa9958版主：关于excel这个代码没有搞懂，运行时出现下面提示

只有本站会员才能查看附件，请登录

1、exPath = App.Path & "\Exc.xlsl"  'excel文件名称
    这句说的是在程序文件夹里面建立Exc.xlsl 文件
2、 Biao = "123"   '表名称
    这句说的123表是模板表  还是什么表

开始以为是excel的属性为只读，点击查看只读和隐藏的√都是去掉的，没有搞懂提示。
3、麻烦版主在解释详细点，谢谢！

'------------------------------------------------------------------------------------------------------------------------------------------
4、另外的方法测试成功！再次谢谢！

只有本站会员才能查看附件，请登录

[此贴子已经被作者于2020-8-25 17:36编辑过]

#8

jklqwe1112020-08-25 22:53

以下是一个函数，是将一个结果集写入指定的工作簿。

程序代码：

Private Sub reOutExcel(scr As Recordset, fileName As String)
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim r As Long
Dim c As Long
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
If Dir(App.Path & "\" & fileName) = "" Then
  Set xlBook = xlApp.Workbooks.Add()
  xlBook.SaveAs App.Path & "\" & fileName
Else
  Set xlBook = xlApp.Workbooks.Open(App.Path & "\" & fileName)
End If
Set xlSheet = xlBook.Worksheets("sheet1")
For c = 0 To scr.Fields.Count - 1
  xlSheet.Cells(1, c + 1) = scr.Fields.Item(c).Name
Next
scr.MoveFirst
r = 1
Do While (scr.EOF <> True)
For c = 0 To scr.Fields.Count - 1
  xlSheet.Cells(r, c + 1) = scr.Fields(c)
Next
scr.MoveNext
r = r + 1
Loop
xlBook.Save
xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub

#9

cwa99582020-08-28 08:12

回复 7楼事业男儿

我的这个代码只是对于excel2003的版本，你的是高版本的excel，数据库引擎不一样的，2003的是 'Excel 8.0;HDR=Yes'"，是8.0版本，你对照你的电脑，看看是多少，一般是11.0以上的吧。