Tách 1 file tổng thành 9 file nhỏ (3 người xem)

[thuatnguyen]

Bạn cần làm rõ thêm một số điểm:
1. Report_1, Report_2, Report_3 có phải là tên của các file muốn tách không? Nếu phải, bạn gởi 3 file mẫu này lên cho mình.
2.
Tools là tên file chứa chương trình chính có thể xử lý dữ liệu của file khác nên không cần phải copy. Ý bạn thế nào?

Vì ở cty không cho phép sử dụng USB nên không thể mang về nhà được tintam7251 ơi. Anh thông cảm nha.


1.Đúng là Report_1, Report_2, Report_3 là 3 file gốc cần tách đó Anh, Anh có thể giúp thiết kế linh động khi thay đổi tên file thì chương trình vẫn sử dụng được, vì tương lai có thể có thêm nhiều Report như vậy.

Em xin nói thêm xíu là ở cột A của mỗi report em lấy tên report đó gắn với Miền tương ứng để dựa vào đó tách file con,

2. Em hiểu ý anh thế này, Có phải từ 3 file gốc khi chọn nút CHIA FILE thì tools sẽ xử lí 3 file cùng lúc luôn không Anh? nếu được như vậy thì tuyệt vời Anh ah, em tưởng tools chỉ có thể xử lí từng file một.

Ah, Giả sử khi có thêm nhiều report thì tools có còn xử lí được không hay chỉ xử lí 3 report như đã thiết kế?

Em đồi hỏi hơi quá rồi, Giả sử khi sếp em hok thích chia ra 3 miền bắc trung nam nữa mà chia thành 4 hoặc 5 miền thì tools còn dùng được không anh?
vì chương trình tách file con trước kia của Anh thì ở cột A có mấy tên phân biệt thì tách thành bấy nhiêu file con, em cứ thế bỏ vào tools từng Report mà xử nó, sau đó copy từng file con cho vào Folder tương ứng.

Cám ơn tintam7251 rất nhiều.

 

[tintam7251]

-Bạn không cần phải lấy file thực từ công ty. Cứ theo file thực mà giả lập đi rồi gởi lên. Mình chỉ cần xem ở cột A, có những gì để căn cứ vào đó mà tách. ( File tools bạn gởi không có).
-Các folder và file được tách ra sẽ có tên như mẫu mà bạn gởi trong bài #18. OK phải không?

 

[thuatnguyen]

-Bạn không cần phải lấy file thực từ công ty. Cứ theo file thực mà giả lập đi rồi gởi lên. Mình chỉ cần xem ở cột A, có những gì để căn cứ vào đó mà tách. ( File tools bạn gởi không có).
-Các folder và file được tách ra sẽ có tên như mẫu mà bạn gởi trong bài #18. OK phải không?

Em gửi Anh 3 Report (giả lập) cần tách, khi tách mỗi report 4 file con nó vào 4 folder như mẫu em gửi kèm, thanks Anh.

 

[tintam7251]

-Đã làm cho bạn đúng theo mẫu. Mình làm tổng quát để tạo thuận lợi cho bạn về sau. Có thể tách nhiều file Report chứ không chỉ 3. Có thể tách nhiều miền. Folder chứa file tách do chương trình tạo ra để tránh gây lỗi. Bạn chạy kiểm tra thử xem có đúng ý chưa.
-Sau đây là code chính:

Option Explicit
Sub Tao_file()
On Error Resume Next
Dim Pathname As String, wbname As String, sFoldername As String, CEOfilename As String
Dim Wb As Workbook, tt As Long
Dim ArrFile(), ArrSheet(), Filename
Dim Rng0 As Range, Rng1 As Range, Rng2 As Range
Dim soFile As Integer, soSheet As Integer, j As Long, iRow As Long
        Application.ScreenUpdating = False
        Frm_Progress.Show
  Pathname = ThisWorkbook.Path
 With New Scripting.FileSystemObject
            For Each Filename In .GetFolder(Pathname & "\Report").Files
                  Workbooks.Open Filename
                 wbname = Mid(Filename, InStrRev(Filename, "\") + 1, Len(Filename) - InStrRev(Filename, "\") + 1)
        With Workbooks(wbname)
                .Activate
                       With ActiveSheet
               .UsedRange.Offset(2).Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlNo
                    ArrFile = UniArray(Range([a3], [A65536].End(xlUp)))
            [COLOR=#008000]'tao cac file mien[/COLOR]
                           For soFile = 0 To UBound(ArrFile)
                                 .UsedRange.Offset(1).AutoFilter Field:=1, Criteria1:=ArrFile(soFile)
                                  Set Rng0 = .AutoFilter.Range
                                   Set Rng1 = Rng0.Offset(1, 1).Resize(, 1).SpecialCells(xlCellTypeVisible)
                                    ArrSheet = UniArray(Rng1)
                                  soSheet = UBound(ArrSheet) + 1
                                          With Application
                                               .SheetsInNewWorkbook = soSheet
                                                Set Wb = .Workbooks.Add
                                          End With
                                        For j = 0 To soSheet - 1
                                          Rng0.AutoFilter Field:=2, Criteria1:=ArrSheet(j)
                                          Set Rng2 = .AutoFilter.Range
                                           Rng2.Offset(-1, 0).Resize(Rng2.Rows.Count + 1).Copy _
                                                 Destination:=Wb.Worksheets("Sheet" & j + 1).Range("A1")
                                                   With Wb.Worksheets("Sheet" & j + 1)
                                                    .Columns.AutoFit
                                                    .Name = ArrSheet(j)
                                                    End With
                                         Next
                                          .AutoFilterMode = False
                                        Application.DisplayAlerts = False
                             sFoldername = "Mien" & Mid(ArrFile(soFile), InStrRev(ArrFile(soFile), "_") + 1, Len(ArrFile(soFile)) - InStrRev(ArrFile(soFile), "_") + 1)
                                       If ExistsFolder(Pathname, sFoldername) = False Then MkDir Pathname & "\" & sFoldername
                                       Wb.SaveAs Filename:=Pathname & "\" & sFoldername & "\" & ArrFile(soFile) & " .xls", FileFormat:= _
                                           xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                                         , CreateBackup:=False
                                       Wb.Close
                              Frm_Progress.ProgressBar (soFile / UBound(ArrFile))
                           Next
                  [COLOR=#00ff00][/COLOR][COLOR=#008080]'tao file CEO[/COLOR][COLOR=#00ff00]
[/COLOR]                     ArrSheet = UniArray(Range(.[b3], [b65536].End(xlUp)))
                With Application
                   .SheetsInNewWorkbook = 1
                    Set Wb = .Workbooks.Add
                End With
            iRow = .Range("A2").CurrentRegion.Rows.Count
           .Range("A2").CurrentRegion.Copy Wb.Sheets("sheet1").Range("A1")
           Wb.Sheets("sheet1").Columns.AutoFit
           Wb.Sheets("sheet1").Name = .Name
            Range("A3:A" & iRow) = Left(wbname, 8) & "_" & .Name
            CEOfilename = Left(wbname, 8) & "_" & .Name
                       For j = 0 To UBound(ArrSheet)
                                  Sheets.Add after:=Sheets(Sheets.Count)
                                  ActiveSheet.Name = ArrSheet(j)
                                     Rng0.AutoFilter Field:=2, Criteria1:=ArrSheet(j)
                                    Set Rng2 = .AutoFilter.Range
                                     Rng2.Offset(-1, 0).Resize(Rng2.Rows.Count + 1).Copy _
                                          Destination:=Worksheets(ArrSheet(j)).Range("A1")
                                  With Worksheets(ArrSheet(j))
                                       .Columns.AutoFit
                                  End With
                       Next
                .AutoFilterMode = False
             End With
                          If ExistsFolder(Pathname, "CEO") = False Then MkDir Pathname & "\" & "CEO"
                           Wb.SaveAs Filename:=Pathname & "\" & "CEO" & "\" & CEOfilename & " .xls", FileFormat:= _
                                      xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                           , CreateBackup:=False
                            Wb.Close
        End With
Workbooks(wbname).Close
   Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Frm_Progress.Hide
End Sub

Function UniArray(vung As Range)
Dim Arr(), i As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr = vung.Value
For i = 1 To UBound(Arr)
  If Not Dic.exists(Arr(i, 1)) And Arr(i, 1) <> "" Then
    Dic.Add Arr(i, 1), ""
  End If
Next
 UniArray = Dic.keys
End Function

Function ExistsFolder(PathFolder As String, FolderName As String) As Boolean
Dim FSO As Object, FolObj As Object
Dim Item
Set FSO = CreateObject("Scripting.FileSystemObject")
  Set FolObj = FSO.GetFolder(PathFolder)
 For Each Item In FolObj.SubFolders
 If Item = PathFolder & "\" & FolderName Then
  ExistsFolder = True
  Exit Function
  Else
  ExistsFolder = False
  End If
  Next
End Function

Sub DelFolder()
Dim FSO As Object, FolObj As Object
Dim Item, fN
Set FSO = CreateObject("Scripting.FileSystemObject")
  Set FolObj = FSO.GetFolder(ThisWorkbook.Path)
     For Each Item In FolObj.SubFolders
          If Item <> "" And Item <> ThisWorkbook.Path & "\Report" Then
               For Each fN In FSO.GetFolder(Item).Files
                    Kill fN
              Next
  RmDir Item
  End If
  Next
End Sub

 

[thuatnguyen]

NÓi gì bây giờ? hơn cả mong đợi của em rồi,
Cám ơn tintam7251 nhiều lắm.