Tách từ file tổng hợp, ở sheet 1(2) theo cột Ghi chu 2 ra các file chi tiết tương ứng

[Excel my love_1]

Em chào cả nhà ạ!
Em có 1 file tổng hợp , ở sheet 1 (2), cột ghi chu 2 có tên của các Đơn vị.
Em cần tách thành các file chi tiết theo tên từng Đơn vị. Như sau:

Cách thức lấy dữ liệu để tách là dựa vào cột Ghi chu 2 ở Sheet 1 (2) của file tổng hợp. Như sau:

Kết quả file chi tiết như sau:


Chi tiết trong file gửi kèm.
Rất mong các anh chị giúp đỡ ạ!

 

[Maika8008]

Chỉ mỗi 1 đơn vị mà thêm dòng Grand Total để làm chi vậy bạn?

 

[Excel my love_1]

Chỉ mỗi 1 đơn vị mà thêm dòng Grand Total để làm chi vậy bạn?

Cảm ơn Maika8008 đã góp ý, mình đã sửa lại bỏ dòng Grand Total ở tất cả các file kết quả
Rất mong bạn giúp đỡ

 

[BuiQuangThuan]

Rất mong bạn giúp đỡ

Option Explicit
Sub ABC()
    Dim Dic As Object, Vung As Range, wbMoi As Workbook
    Dim Arr, n&, iRow&, i&, S
    Dim sFolder$, TenFile$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dic = CreateObject("Scripting.Dictionary")
sFolder = ThisWorkbook.Path & "\"
TenFile = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
With ThisWorkbook.Sheets("Sheet1 (2)")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    iRow = .Range("H" & Rows.Count).End(xlUp).Row
    Set Vung = .Range("A1:H" & iRow)
    Arr = .Range("H2:H" & iRow).Value
    For i = 1 To UBound(Arr, 1)
        If Not Arr(i, 1) Like "*Total" Then
            If Dic.exists(Arr(i, 1)) = False Then
                Dic.Add (Arr(i, 1)), ""
            End If
        End If
    Next
End With
For Each S In Dic.keys
    Set wbMoi = Workbooks.Add(1)
    wbMoi.Sheets(1).Name = S
    Vung.AutoFilter 8, S
    Vung.Copy wbMoi.Sheets(1).Range("A1")
    wbMoi.SaveAs sFolder & TenFile & "-" & S, xlOpenXMLWorkbook
    wbMoi.Close True
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Ða tach File xong", , "THÔNG BÁO"
End Sub

Thử code này coi đúng ý bạn không?

 

[Excel my love_1]

Option Explicit
Sub ABC()
    Dim Dic As Object, Vung As Range, wbMoi As Workbook
    Dim Arr, n&, iRow&, i&, S
    Dim sFolder$, TenFile$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dic = CreateObject("Scripting.Dictionary")
sFolder = ThisWorkbook.Path & "\"
TenFile = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
With ThisWorkbook.Sheets("Sheet1 (2)")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    iRow = .Range("H" & Rows.Count).End(xlUp).Row
    Set Vung = .Range("A1:H" & iRow)
    Arr = .Range("H2:H" & iRow).Value
    For i = 1 To UBound(Arr, 1)
        If Not Arr(i, 1) Like "*Total" Then
            If Dic.exists(Arr(i, 1)) = False Then
                Dic.Add (Arr(i, 1)), ""
            End If
        End If
    Next
End With
For Each S In Dic.keys
    Set wbMoi = Workbooks.Add(1)
    wbMoi.Sheets(1).Name = S
    Vung.AutoFilter 8, S
    Vung.Copy wbMoi.Sheets(1).Range("A1")
    wbMoi.SaveAs sFolder & TenFile & "-" & S, xlOpenXMLWorkbook
    wbMoi.Close True
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Ða tach File xong", , "THÔNG BÁO"
End Sub

Thử code này coi đúng ý bạn không?

Tuyệt vời bạn ơi! Code ra đúng đến 96,69% ý của mình rồi. Chỉ còn cái dòng Total ở các file chi tiết , mong bạn thương thì thương cho trót, giúp mình sửa code sao cho để cái dòng Total đó nó theo tên đơn vị (như mình ví dụ này)

Mình gửi kèm file đã chèn code của bạn để bạn tiện xử lý.
Cảm ơn bạn nhiều nhiều

 

[BuiQuangThuan]

Bạn có thể chờ xem ai đó giúp hay không. Còn không thì để mai. Mình sẽ code nốt cho

 

[Hoàng Tuấn 868]

giúp mình sửa code sao cho để cái dòng Total đó nó theo tên đơn vị

Chỉnh hộ bạn Thuận một chút.

 

[Maika8008]

Option Explicit
Sub ABC()
    Dim Dic As Object, Vung As Range, wbMoi As Workbook
    Dim Arr, n&, iRow&, i&, S
    Dim sFolder$, TenFile$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dic = CreateObject("Scripting.Dictionary")
sFolder = ThisWorkbook.Path & "\"
TenFile = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
With ThisWorkbook.Sheets("Sheet1 (2)")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    iRow = .Range("H" & Rows.Count).End(xlUp).Row
    Set Vung = .Range("A1:H" & iRow)
    Arr = .Range("H2:H" & iRow).Value
    For i = 1 To UBound(Arr, 1)
        If Not Arr(i, 1) Like "*Total" Then
            If Dic.exists(Arr(i, 1)) = False Then
                Dic.Add (Arr(i, 1)), ""
            End If
        End If
    Next
End With
For Each S In Dic.keys
    Set wbMoi = Workbooks.Add(1)
    wbMoi.Sheets(1).Name = S
    Vung.AutoFilter 8, S
    Vung.Copy wbMoi.Sheets(1).Range("A1")
    wbMoi.SaveAs sFolder & TenFile & "-" & S, xlOpenXMLWorkbook
    wbMoi.Close True
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Ða tach File xong", , "THÔNG BÁO"
End Sub

Thử code này coi đúng ý bạn không?

Không dùng dic thì gọn code hơn nhỉ?

 

[BuiQuangThuan]

Không dùng dic thì gọn code hơn nhỉ?

Nếu không dùng dic. Em chưa nghĩ ra cách nào để có thể lọc ra key duy nhất luôn ấy. Anh có ý tưởng nào với bài này không ạ

 

[Maika8008]

Nếu không dùng dic. Em chưa nghĩ ra cách nào để có thể lọc ra key duy nhất luôn ấy. Anh có ý tưởng nào với bài này không ạ

Tôi nghĩ mỗi đoạn total đó là duy nhất rồi chứ.

 

[Excel my love_1]

Chỉnh hộ bạn Thuận một chút.

Cảm ơn anh Hoàng Tuấn 868, code ra đúng ý 100% rồi ạ
Mọi người hỗ trợ nhiệt tình, em rất vui
Chúc cả nhà sức khỏe dồi dào và nhiều niềm vui

Bài đã được tự động gộp: 27/10/21

Không dùng dic thì gọn code hơn nhỉ?

Rất mong học hỏi thêm từ Maika8008.
Trước mình thấy Maika8008 giải dạng bài này siêu lắm (link gửi kèm), mà không tài nào học được code của bạn,mình mót code của bạn rồi sửa tới sửa lui mà ra tùm lum không à.
https://www.giaiphapexcel.com/diendan/threads/xuất-dữ-liệu-từ-1-file-excel-tổng-ra-nhiều-file-excel-con.150300/