• Tùy chọn
• Đăng nhập
• Đăng ký
• Xem như trên Máy tính
• Accelerated Mobile Pages Theme

Tách file và đặt tên theo ý muốn

• Trang chủ

  • Thủ Thuật Access
  • Access Nâng Cao
  • Thủ thuật VBA
  • [Hàm] Tách file và đặt tên theo ý muốn
• Tách file và đặt tên theo ý muốn

• Tách file và đặt tên theo ý muốn

  teutamteu > 18-12-17, 04:56 PM

  Em chào các bác.
  Em đang tổng hợp dữ liệu chuyển hàng cho các đơn vị.
  Em có 1 bảng tên "ban hang" có 5 trường dữ liệu trong đó có 1 trường em để là "TINH" (Tỉnh). Em muốn xuất tự động mỗi tỉnh thành các file với tên có định dạng "teeb tỉnh + nội dung mong muốn"
  Tuy nhiên khi chạy xong thì có 2 vấn đề:
  1. Thiếu tiêu đề file
  2. Không đặt được tên file theo ý muốn (cơ bản code chỉ xuất ra tên tỉnh như Hà Nội, Hải Phòng...) => Mất công sửa tên file. (lý do: chưa biết cách code thế nào)
  Nhờ các bác tư vấn thêm giúp em.
  Em cám ơn!
  
  Lưu ý: Dữ liệu tổng cả năm sẽ lớn hơn 65K dòng nên code e để xuất ra dạng *.xlsx
  
  Option Compare Database
  Option Explicit
  Private Sub Command2_Click()
      Dim db As DAO.Database
      Dim rs, rs1 As DAO.Recordset
      Dim objExcelApp, wb As Object
      Dim myPath, strTinh As String
      Dim varReturn As Variant
      DoCmd.Hourglass True
      Set objExcelApp = CreateObject("Excel.Application")
      myPath = Access.CurrentProject.Path
      Set db = CurrentDb()
      Set rs = db.OpenRecordset("SELECT DISTINCT TINH FROM [Ban hang]", dbOpenDynaset)
      objExcelApp.DisplayAlerts = False
      Do While Not rs.EOF
          strTinh = rs("TINH")
          varReturn = SysCmd(acSysCmdSetStatus, "----->Dang xuat du lieu cho tinh: " & strTinh)
          Set rs1 = db.OpenRecordset("SELECT * FROM [Ban hang] where TINH like'" & strTinh & "'", dbOpenDynaset)
          Set wb = objExcelApp.Workbooks.Add
          Dim ws As Object
          Set ws = wb.Sheets(1)
          ws.Cells(2, 1).copyfromrecordset rs1
          wb.SaveAs myPath & "\" & strTinh
          wb.Close
          rs.MoveNext
      Loop
      varReturn = SysCmd(acSysCmdSetStatus, " ")
      objExcelApp.DisplayAlerts = True
      Set rs = Nothing
      Set rs1 = Nothing
      Set db = Nothing
      Set objExcelApp = Nothing
      DoCmd.Hourglass False
      MsgBox "Da thuc hien xong viec xuat du lieu.", vbExclamation
  End Sub

• RE: Tách file và đặt tên theo ý muốn

  teutamteu > 18-12-17, 04:58 PM

  Em hỏi thêm làm thế nào chèn file vào được ah, không có file ví dụ sợ mọi người không hiểu

• RE: Tách file và đặt tên theo ý muốn

  Noname > 18-12-17, 05:16 PM

  Chào bạn, bạn có thể đưa file lên 1 trang chia sẻ rồi dẫn link qua.
  Xem thêm
  http://thuthuataccess.com/forum/announcement-1.html

• RE: Tách file và đặt tên theo ý muốn

  maidinhdan > 18-12-17, 10:49 PM

  Xem code này mà chỉnh lai
  
  
  

  Mã PHP:

  Function ExportExcel()

Dim oApp As New Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
    ' Tao phien lam viec Excel voi Duongdanfile
   Set oBook = oApp.Workbooks.Add   'Neu dung file mau thi doi .Add thanh .Open(DuongdanFile)
   Set oSheet = oBook.Sheets("Sheet1")        ' Neu co file mau doi ten Sheet cu the
    Dim Tenfile As String
'    Dim DB As DAO.Database
    Dim rs1 As DAO.Recordset
    Dim rs As DAO.Recordset
    ' tao recordset la Tentable
    Set rs1 = CurrentDb.OpenRecordset("SELECT * FROM tblMucLuc", dbOpenDynaset)
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblNguoigiaodich", dbOpenDynaset)
    If rs1.EOF Then Exit Function
    rs1.MoveFirst
    Do Until rs1.EOF
         ' Chep du lieu len Excel
        oSheet.Range("A1") = "Tieu de trong Bao cao" & "_" & rs1.Fields("Noidungbaocao")
        oSheet.Range("A4").CopyFromRecordset rs         'Xuat tu cot A4 tro xuong

         Tenfile = "D:\" & rs1.Fields("TenTinh") & "_" & rs1.Fields("Noidung")
         oBook.SaveAs Tenfile, 51   '51 la dinh dang kieu Excel *.xlsx
    rs1.MoveNext
    Loop
' Xoa bien va giai phong bo nho
   rs1.Close
   rs.Close
   oBook.Close
   oApp.Quit

End Function 


  
  Nhớ đăng ký thêm thư viện Excel nhé;
  Lưu ý rs1 của bạn trong vòng lặp, nên set = nothing sau dòng rs.Movenext; Lý do mỗi vòng lặp sẽ làm tràn bộ nhớ Ram khi gọi truy vấn với điều kiện mới
• Bài trước Bài tiếp