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

韩建硕　发表于：2017-12-18 13:55:15 　

复制

具体需求

Top

仙来发表于：2017-12-18 20:05:51

http://www.accessoft.com/blog/article-show.asp?userid=30269&Id=16829

Top

西出阳关无故人发表于：2017-12-19 07:59:57

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

Top

fjfjb951 发表于：2017-12-19 20:03:39

二楼代码能实现!

Top

王大哥1314 发表于：2017-12-20 20:54:26

谢谢杨恒的指导！记得要引用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

Top

总记录：4篇页次：1/1 9 1 :

Access交流中心

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