<output id="os3gq"><ruby id="os3gq"></ruby></output>

    1. <mark id="os3gq"></mark>
    2. Access交流中心

      北京 | 上海 | 天津 | 重慶 | 廣州 | 深圳 | 珠海 | 汕頭 | 佛山 | 中山 | 東莞 | 南京 | 蘇州 | 無錫 | 常州 | 南通 | 揚州 | 徐州 | 杭州 | 溫州 | 寧波 | 臺州 | 福州 | 廈門 | 泉州 | 龍巖 | 合肥 | 蕪湖 | 成都 | 遂寧 | 長沙 | 株洲 | 湘潭 | 武漢 | 南昌 | 濟南 | 青島 | 煙臺 | 濰坊 | 淄博 | 濟寧 | 太原 | 鄭州 | 石家莊 | 保定 | 唐山 | 西安 | 大連 | 沈陽 | 長春 | 昆明 | 蘭州 | 哈爾濱 | 佳木斯 | 南寧 | 桂林 | ? | 貴陽 | 西寧 | 烏魯木齊 | 包頭 |

      回復 加入收藏帖  復制
      我要提問 帖子上移

      為access數據庫做一個可以分類導出為Excel文件的vba代碼,酬金150元

      韓建碩 等級: 普通會員 積分:0 金幣:0 來自:阜新Access交流中心 發表于:2017-12-18 13:55:15  
      樓主

      具體需求

       

      access培訓  誠聘access開發人員

          韓建碩
            獲得社區協助:請教問題(即發帖)1篇,其中獲得解決的0篇;
            協助社區成員:協助他人(即回帖)0篇,其中被設為【最佳答案】的0篇;
            協助我們社區:發布技術文章0篇,邀請了0名新會員注冊本社區(如何邀請會員注冊,詳見:http://www.www.beijingfeeling.com/sitehelp.asp)。
      Top

      掃描下方工作人員的微信二維碼加微信,邀您加入Access課堂微信群,進入一個技術交際圈:

      網站工作人員微信

      仙來 等級:一星助教★ 積分:679 金幣:2294 來自:池州Access交流中心 發表于2017/12/18 20:05:51 
      1樓 得分: 0
          希望我的回答能解決了您的問題,或者所附上的這些信息對您有所幫助!如有任何疑問或需要進一步幫助,請您直接在本站發貼,我們非常樂意幫助您解決問題!
          如果我的回答已經解決了您的問題,請點擊上方的“最佳答案”,這樣本帖子就不會在“待解決問題區”顯示了,以方便大家對那些正在等待解決的帖子給予關注!
          仙來  [協助社區成員回帖744篇,其中【最佳答案】237篇;發布技術文章49篇。]
          Access軟件網助教團隊 
          http://www.umvsoft.com
          如果您沒有注冊這個論壇,請單擊下面的鏈接進行注冊,與我在論壇進行交流:
          http://www.www.beijingfeeling.com/reg/reg.asp?userid=30269
          本貼子以“現狀”提供且沒有任何擔保,同時也沒有授予任何權利。
      西出陽關無故人 等級:版主★★★★★ 積分:640 金幣:120 來自:安順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篇;
            協助社區成員:協助他人(即回帖)880篇,其中被設為【最佳答案】的239篇;
            協助我們社區:發布技術文章3篇,邀請了0名新會員注冊本社區(如何邀請會員注冊,詳見:http://www.www.beijingfeeling.com/sitehelp.asp)。
      fjfjb951 等級:一星助教★ 積分:56 金幣:26 來自:漳州Access交流中心 發表于2017/12/19 20:03:39 
      3樓 得分: 0

      二樓代碼能實現!



          希望我的回答能解決了您的問題,或者所附上的這些信息對您有所幫助!如有任何疑問或需要進一步幫助,請您直接在本站發貼,我們非常樂意幫助您解決問題!
          如果我的回答已經解決了您的問題,請點擊上方的“最佳答案”,這樣本帖子就不會在“待解決問題區”顯示了,以方便大家對那些正在等待解決的帖子給予關注!
          fjfjb951  [協助社區成員回帖15篇,其中【最佳答案】4篇;發布技術文章0篇。]
          Access軟件網助教團隊 
          http://www.umvsoft.com
          如果您沒有注冊這個論壇,請單擊下面的鏈接進行注冊,與我在論壇進行交流:
          http://www.www.beijingfeeling.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.www.beijingfeeling.com/reg/reg.asp?userid=39353
          本貼子以“現狀”提供且沒有任何擔保,同時也沒有授予任何權利。
      總記錄:4篇  頁次:1/1 9 1 :
      您還沒有在Access軟件網登錄不能回復帖子
      • 你沒有登錄,請點擊后面鏈接登錄:登錄
      • 如果你沒有注冊,請點擊后面鏈接注冊:注冊,注冊完成后,請再次訪問本頁功能。
       
      湖北11选5