Access交流中心

北京 | 上海 | 天津 | 重庆 | 广州 | 深圳 | 珠海 | 汕头 | 佛山 | 中山 | 东莞 | 南京 | 苏州 | 无锡 | 常州 | 南通 | 扬州 | 徐州 | 杭州 | 温州 | 宁波 | 台州 | 福州 | 厦门 | 泉州 | 龙岩 | 合肥 | 芜湖 | 成都 | 遂宁 | 长沙 | 株洲 | 湘潭 | 武汉 | 南昌 | 济南 | 青岛 | 烟台 | 潍坊 | 淄博 | 济宁 | 太原 | 郑州 | 石家庄 | 保定 | 唐山 | 西安 | 大连 | 沈阳 | 长春 | 昆明 | 兰州 | 哈尔滨 | 佳木斯 | 南宁 | 桂林 | 海口 | 贵阳 | 西宁 | 乌鲁木齐 | 包头 |

回复 加入收藏帖  复制
我要提问 帖子上移

为access数据库做一个可以分类导出为Excel文件的vba代码,酬金150元

韩建硕 等级: 普通会员 积分:0 金币:0 来自:阜新Access交流中心 发表于:2017-12-18 13:55:15  
楼主

具体需求

 

access培训  诚聘access开发人员

    韩建硕
      获得社区协助:请教问题(即发帖)1篇,其中获得解决的0篇;
      协助社区成员:协助他人(即回帖)0篇,其中被设为【最佳答案】的0篇;
      协助我们社区:发布技术文章0篇,邀请了0名新会员注册本社区(如何邀请会员注册,详见:http://www.accessoft.com/sitehelp.asp)。
Top
仙来 等级:一星助教★ 积分:531 金币:2094 来自:池州Access交流中心 发表于2017/12/18 20:05:51 
1楼 得分: 0
    希望我的回答能解决了您的问题,或者所附上的这些信息对您有所帮助!如有任何疑问或需要进一步帮助,请您直接在本站发贴,我们非常乐意帮助您解决问题!
    如果我的回答已经解决了您的问题,请点击上方的“最佳答案”,这样本帖子就不会在“待解决问题区”显示了,以方便大家对那些正在等待解决的帖子给予关注!
    仙来  [协助社区成员回帖540篇,其中【最佳答案】168篇;发布技术文章44篇。]
    Access软件网助教团队 
    http://www.umvsoft.com
    如果您没有注册这个论坛,请单击下面的链接进行注册,与我在论坛进行交流:
    http://www.accessoft.com/reg/reg.asp?userid=30269
    本贴子以“现状”提供且没有任何担保,同时也没有授予任何权利。
西出阳关无故人 等级:普通会员 积分:388 金币:40 来自:安顺Access交流中心 发表于2017/12/19 7:59:57 
2楼 得分: 0
Private Sub Command0_Click()
' On Error Resume Next
    Dim i As Long
    Dim rec As ADODB.Recordset, rst As ADODB.Recordset
    Dim thePath    '目的文件夹
    Dim fso As New FileSystemObject, fldr As Folder    '引用microsoft scripting runtime
    Dim xlApp As Object, xlBook As Object, j As Integer
    Set rec = New ADODB.Recordset
    rec.Open "select 省份,医院 from demo group by 省份,医院 order by 省份,医院", CurrentProject.Connection, adOpenStatic, adLockReadOnly
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Dim A, B As Long
    For i = 1 To rec.RecordCount
        If Dir(CurrentProject.Path & "\导出", vbDirectory) = "" Then    '如果目的目录不存在,就创建文件夹
            Set fldr = fso.CreateFolder(CurrentProject.Path & "\导出")
        End If
        If Dir(CurrentProject.Path & "\导出\" & Trim(rec.Fields(0)), vbDirectory) = "" Then    '如果目的目录不存在,就创建文件夹
            Set fldr = fso.CreateFolder(CurrentProject.Path & "\导出\" & Trim(rec.Fields(0)))
        End If
        Set rst = New ADODB.Recordset
        rst.Open "select * from demo where 省份='" & rec.Fields(0) & "' and 医院='" & rec.Fields(1) & "'", CurrentProject.Connection, adOpenStatic, adLockReadOnly
        If rst.RecordCount > 0 Then
            Set xlBook = xlApp.Workbooks.Add
            For j = 1 To rst.Fields.Count
                xlBook.Sheets(1).Cells(1, j) = rst.Fields(j - 1).Name
            Next j
            'xlBook.Sheets(1).Range("A2").CopyFromRecordset rst,OLE或长文本字段会有错误
            For A = 1 To rst.RecordCount
                For j = 1 To rst.Fields.Count
                    xlBook.Sheets(1).Cells(A + 1, j) = rst.Fields(j - 1)
                Next j
            Next A
            xlBook.SaveAs CurrentProject.Path & "\导出\" & Trim(rec.Fields(0)) & "\" & rec.Fields(1) & ".xls"
            xlBook.Close
            Set xlBook = Nothing
        End If
        rec.MoveNext
    Next i
    MsgBox "导出完毕!"
    Shell "explorer /e,/select," & CurrentProject.Path & "\导出", 1
End Sub



    很高兴与您就本帖子进行交流,如果我的回答已经解决了您的问题,请点击上方的“最佳答案”,这样本帖子就不会在“待解决问题区”显示了,我也将获得2个积分奖励,并不会减少您的积分!
    西出阳关无故人
      获得社区协助:请教问题(即发帖)18篇,其中获得解决的9篇;
      协助社区成员:协助他人(即回帖)659篇,其中被设为【最佳答案】的171篇;
      协助我们社区:发布技术文章1篇,邀请了0名新会员注册本社区(如何邀请会员注册,详见:http://www.accessoft.com/sitehelp.asp)。
fjfjb951 等级:一星助教★ 积分:54 金币:26 来自:漳州Access交流中心 发表于2017/12/19 20:03:39 
3楼 得分: 0

二楼代码能实现!



    希望我的回答能解决了您的问题,或者所附上的这些信息对您有所帮助!如有任何疑问或需要进一步帮助,请您直接在本站发贴,我们非常乐意帮助您解决问题!
    如果我的回答已经解决了您的问题,请点击上方的“最佳答案”,这样本帖子就不会在“待解决问题区”显示了,以方便大家对那些正在等待解决的帖子给予关注!
    fjfjb951  [协助社区成员回帖13篇,其中【最佳答案】3篇;发布技术文章0篇。]
    Access软件网助教团队 
    http://www.umvsoft.com
    如果您没有注册这个论坛,请单击下面的链接进行注册,与我在论坛进行交流:
    http://www.accessoft.com/reg/reg.asp?userid=33089
    本贴子以“现状”提供且没有任何担保,同时也没有授予任何权利。
王大哥1314 等级:二星助教★★ 积分:110 金币:286 来自:衡水Access交流中心 发表于2017/12/20 20:54:26 
4楼 得分: 0

谢谢杨恒的指导!记得要引用Microsoft Scripting Runtime

Private Sub 导出_Click()

    Dim t1
    Dim qry As dao.QueryDef
    Dim sql As String
    Dim sql1 As String
    Dim sql2 As String
    Dim fso As New FileSystemObject
    Dim BookName As String
    Dim FolderPath As String
    Dim rst As New ADODB.Recordset
    Dim rst1 As New ADODB.Recordset

    On Error Resume Next
    t1 = Timer
    sql = "SELECT distinct 省份 FROM demo"
    rst.Open sql, CurrentProject.Connection, 2, 3
    rst.MoveFirst
    Do Until rst.EOF
        BookName = Replace(rst!省份, " ", "")
        FolderPath = CurrentProject.Path & "\" & BookName
        If fso.FolderExists(FolderPath) Then fso.DeleteFolder FolderPath
        MkDir FolderPath
        sql1 = "select distinct 医院 from demo where 省份='" & BookName & "'"
        rst1.Open sql1, CurrentProject.Connection, 2, 3
        rst1.MoveFirst
        Do Until rst1.EOF
            sql2 = "select * from demo where   省份='" & BookName & "' and 医院='" & rst1!医院 & "'"
            Set qry = CurrentDb.CreateQueryDef(rst1!医院, sql2)
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, qry.Name, FolderPath & "\" & qry.Name & ".xls", True
            DoCmd.DeleteObject acQuery, rst1!医院
            rst1.MoveNext
        Loop
        rst1.Close
        rst.MoveNext
    Loop
    rst.Close
    
    Set rst = Nothing
    Set rst1 = Nothing
    MsgBox "导出完毕!" & Chr(13) & "用时" & Format(Timer - t1, "0.00") & "秒"

End Sub



    希望我的回答能解决了您的问题,或者所附上的这些信息对您有所帮助!如有任何疑问或需要进一步帮助,请您直接在本站发贴,我们非常乐意帮助您解决问题!
    如果我的回答已经解决了您的问题,请点击上方的“最佳答案”,这样本帖子就不会在“待解决问题区”显示了,以方便大家对那些正在等待解决的帖子给予关注!
    王大哥1314  [协助社区成员回帖6篇,其中【最佳答案】0篇;发布技术文章4篇。]
    Access软件网助教团队 
    http://www.umvsoft.com
    如果您没有注册这个论坛,请单击下面的链接进行注册,与我在论坛进行交流:
    http://www.accessoft.com/reg/reg.asp?userid=39353
    本贴子以“现状”提供且没有任何担保,同时也没有授予任何权利。
总记录:4篇  页次:1/1 9 1 :
您还没有在Access软件网登录不能回复帖子
  • 你没有登录,请点击后面链接登录:登录
  • 如果你没有注册,请点击后面链接注册:注册,注册完成后,请再次访问本页功能。