Xuất nhiều sheet thành file excel

7 Responses

1. lamhuu92 says:

   07/09/2024 at 4:04 pm

   e chưa làm được ý cuối cùng, xuất ra nhiều folder khác nhau cùng lúc
   E đang làm thành nhiều Sub và gọi vào sub TongHop

   theo kiểu này

   [I][COLOR=#008000]'' lập 2 mảng, mảng 1 chứa tên các sheets[/COLOR][/I]
   ArrTenSheets= Array(    Array("Report1", "DNTN1"), Array("Report2", "DNTN2"),Array("Report3", "DNTN3") )
   ArrTenFolders=Array(     "C:BaoCaoKetqua1",       "C:BaoCaoKetqua2",       "C:BaoCaoKetqua3" )
   
   [COLOR=#008000][I]''rồi dùng FOR truy cập lặp là xong[/I][/COLOR]
   
   For i=1 to ubound(ArrrTenFolders)
         [I][COLOR=#008000] ''xu ly cho arrTenSheets(i), và ArrrTenFolders(i) GIONG NHU SUB bạn đã làm -- hoặc gọi SUB truyền tham số luôn là OK[/COLOR][/I]
   
   next i

   Reply
2. lamhuu92 says:

   07/09/2024 at 4:04 pm

   Thử chạy code này
   Giả sử bạn lưu các đường dẫn cần copy tới từ ô A1 đến ô A5 của sheet1:

   Sub XuatExcelTest()
       Application.DisplayAlerts = False
       Dim Path, i As Long
       Dim Name As String
       Name = "TEST"
       With Sheet1
           Path = .Range("A1:A5").Value
       End With
       Sheets(Array("Report", "DNTN")).Copy
       With ActiveWorkbook
           For i = 1 To UBound(Path)
           .SaveAs Path(i, 1) & Name, 50
                   ' 50 xuat ra XLSB
                   ' 18 xuat ra XLS 97 - 2003
                   ' 51 xuat ra XLSX
                   ' 52 xuat ra XLSM
           Next
           .Close   
       End With
       Application.DisplayAlerts = True
   End Sub

   Reply
3. laiphuquan says:

   07/09/2024 at 4:05 pm

   Cho em hỏi thêm những sheet em xuất ra nó có kèm theo vài cái shape em muốn nó xoá đi luôn thì phải thêm code như thế nào?
   Mong được anh và mọi người giúp đỡ!

   Sub CreateNewFile()
   Dim path As String, NewFileName As String
   path = "D:BAOCAO"
   NewFileName = "Test"
   Application.CopyObjectsWithCells = False
   Sheets(Array("Sheet1", "Sheet2")).Copy
   With ActiveWorkbook
   .SaveAs path & NewFileName, 18 '50,51,52
   .Close
   End With
   Application.CopyObjectsWithCells = True
   End Sub

   Với code này mà kêu record macro thì chắc không khả thi rồi.

   Reply
4. laiphuquan says:

   07/09/2024 at 4:06 pm

   Làm phiền anh và các bạn giúp thêm 1 tí nữa: Em muốn đưa 1 vài module đi kèm với file vừa xuất ra thì phải thêm code như thế nào?
   Mong được anh và mọi người giúp đỡ!

   Chẳng có gì là không thể.
   Muốn xuất module ra thì

   Application.VBE.ActiveVBProject.VBComponents("Module1").Export "AddModule.bas"

   Muốn lấy vào thì

   Application.VBE.ActiveVBProject.VBComponents.Import "AddModule.bas"

   Reply
5. laiphuquan says:

   07/09/2024 at 4:06 pm

   Em thêm code vào để export ra nhưng nó báo lỗi ngay dòng code export luôn anh.

   Bạn phải vào Macro Security, tìm mục macro setting rồi check trong mục Trust Access to The VBA Project
   Nếu muốn tự động luôn thì thêm mấy dòng lệnh này vào đầu code

   Dim regKey As String
   regKey = "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & Application.Version & "ExcelSecurityAccessVBOM"
   CreateObject("WScript.Shell").RegWrite regKey, 1, "REG_DWORD"
   Application.VBE.ActiveVBProject.VBComponents.Import "AddModule.bas"
   Kill "AddModule.bas"

   Reply
6. laiphuquan says:

   07/09/2024 at 4:10 pm

   Sau khi vận dụng code của các thành viên, e ra code này, xuất ra nhiều Folder khác nhau (đường dẫn lưu ở sheet7), code chạy tốt:

   Sub XuatExcelTest()
       Application.DisplayAlerts = False
       On Error Resume Next
       Dim Path, i As Long
       Dim Name As String
       Name = "ABC"
       With Sheet7
           Path = .Range("V2:V8").Value
       End With
       Sheets(Array("Report","DNTN")).Copy
       With ActiveWorkbook
           For i = 1 To UBound(Path)
           .SaveAs Path(i, 1) & Name, 50
                   ' 50 xuat ra XLSB
                   ' 18 xuat ra XLS 97 - 2003
                   ' 51 xuat ra XLSX
                   ' 52 xuat ra XLSM
           Next
           .Close
       End With
       MsgBox "Data has been successfully Exported!"
       Application.DisplayAlerts = True
   End Sub

   Tuy nhiên Cho e hỏi thêm 1 chút, Một số sheet xuất ra của em có code, e không muốn copy phần code của sheet sang file mới thì thay đổi code thế nào?
   E xin cảm ơn

   Đơn giản nhất là thay số 50 thành số 51 là được rồi

   Sub DeleteAllVBACode()
   Dim VBProj As VBIDE.VBProject
   Dim VBComp As VBIDE.VBComponent
   Dim CodeMod As VBIDE.CodeModule
   Set VBProj = ActiveWorkbook.VBProject
   For Each VBComp In VBProj.VBComponents
   If VBComp.Type = vbext_ct_Document Then
   Set CodeMod = VBComp.CodeModule
   CodeMod.DeleteLines 1, CodeMod.CountOfLines
   Else
   VBProj.VBComponents.Remove VBComp
   End If
   Next VBComp
   End Sub

   Reply
7. lamhuu92 says:

   07/09/2024 at 4:17 pm

   Sub XuatExcelTest()
       Application.DisplayAlerts = False
       On Error Resume Next
       Dim Path, i As Long
       Dim Name As String
       Name = "ABC"
       With Sheet7
           Path = .Range("V2:V8").Value
       End With
       Sheets(Array("Report","DNTN")).Copy
       With ActiveWorkbook
     DeleteAllVBACode        
     For i = 1 To UBound(Path)
           .SaveAs Path(i, 1) & Name, 50
                   ' 50 xuat ra XLSB
                   ' 18 xuat ra XLS 97 - 2003
                   ' 51 xuat ra XLSX
                   ' 52 xuat ra XLSM
           Next
           .Close
       End With
       MsgBox "Data has been successfully Exported!"
       Application.DisplayAlerts = True
   End Sub

   Sub DeleteAllVBACode()
   Dim VBProj As VBIDE.VBProject
   Dim VBComp As VBIDE.VBComponent
   Dim CodeMod As VBIDE.CodeModule
     Set VBProj = ActiveWorkbook.VBProject
       For Each VBComp In VBProj.VBComponents
          If VBComp.Type = vbext_ct_Document Then
             Set CodeMod = VBComp.CodeModule
             CodeMod.DeleteLines 1, CodeMod.CountOfLines
          Else
             VBProj.VBComponents.Remove VBComp
          End If
       Next VBComp
   End Sub

   Reply