Tách 1 sheet thành nhiều sheet theo điều kiện

Liên hệ QC
cái này nếu vừa muốn tách vừa muốn các sheet con tự động thay đổi khi dữ liệu tổng thay đổi thì làm sao ạ
Chắc phải thuê người canh, khi nào dữ liệu tổng thay đổi xong hẳn rồi mới bấm nút tách. Chứ không đang thay đổi chưa xong nó đã tách rồi thì bất tiện lắm.
 
Chào Anh/Chị,
Em có 1 file dữ liệu gồm 1 sheet Tổng hợp , Giờ muốn tách sheet tổng hợp này thành nhiều sheet chia theo Mã Cửa Hàng ạ
Em cảm ơn ạ.
 

File đính kèm

  • Dữ liệu doanh số.xlsx
    21.4 KB · Đọc: 4

File đính kèm

  • Dữ liệu doanh số.xlsm
    29.8 KB · Đọc: 10

File đính kèm

  • Split_Data_Fix.xlsb
    68.1 KB · Đọc: 7
bạn ơi, file hôm qua mình quên chừa dự phòng tăng số cột nhiều hơn hiện tại, bạn có thể chỉnh lại giùm mình với file mới này không ạ. cám ơn bạn.
Mượn code của Anh @CHAOQUAY để làm bài.
Mong 2 anh @Hoàng Tuấn 868 và Anh @CHAOQUAY thông cảm về sự "lanh chanh" này.
Mã:
Option Explicit
'By ChaoQuay
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, C&, Arr()
    Dim dic As Object, Key$, Ws As Worksheet, Rng As Range
    Set dic = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "TH" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("TH")
        C = .Range("B4").End(xlToRight).Column
        Set Rng = .Range(.Cells(1, 2), .Cells(5, C))
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = Range(.Cells(6, 2), .Cells(Lr, C)).Value

        For i = 1 To UBound(Arr)
            If Arr(i, 2) <> "" Then
                Key = Arr(i, 2)
                If Not dic.exists(Key) Then
                    dic.Add (Key), ""
                    Worksheets.Add after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Key
                End If
            End If
        Next i
            For Each Ws In Worksheets
                If Ws.Name <> "TH" Then
                    ReDim Res(1 To UBound(Arr), 1 To C)
                    For i = 1 To UBound(Arr)
                        If Arr(i, 2) = Ws.Name Then
                            k = k + 1: Res(k, 1) = k
                            For j = 2 To 10
                                Res(k, j) = Arr(i, j)
                            Next j
                        End If
                    Next i
                End If
                If k Then
                    Rng.Copy Ws.Range("B1")
                    Ws.Range("B6").Resize(k, C).Value = Res
                    Ws.Range("D6").CurrentRegion.Borders.LineStyle = 1
                    Ws.Range("D6").CurrentRegion.EntireColumn.AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
 
Mượn code của Anh @CHAOQUAY để làm bài.
Mong 2 anh @Hoàng Tuấn 868 và Anh @CHAOQUAY thông cảm về sự "lanh chanh" này.
Mã:
Option Explicit
'By ChaoQuay
Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, C&, Arr()
    Dim dic As Object, Key$, Ws As Worksheet, Rng As Range
    Set dic = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "TH" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("TH")
        C = .Range("B4").End(xlToRight).Column
        Set Rng = .Range(.Cells(1, 2), .Cells(5, C))
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = Range(.Cells(6, 2), .Cells(Lr, C)).Value

        For i = 1 To UBound(Arr)
            If Arr(i, 2) <> "" Then
                Key = Arr(i, 2)
                If Not dic.exists(Key) Then
                    dic.Add (Key), ""
                    Worksheets.Add after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = Key
                End If
            End If
        Next i
            For Each Ws In Worksheets
                If Ws.Name <> "TH" Then
                    ReDim Res(1 To UBound(Arr), 1 To C)
                    For i = 1 To UBound(Arr)
                        If Arr(i, 2) = Ws.Name Then
                            k = k + 1: Res(k, 1) = k
                            For j = 2 To 10
                                Res(k, j) = Arr(i, j)
                            Next j
                        End If
                    Next i
                End If
                If k Then
                    Rng.Copy Ws.Range("B1")
                    Ws.Range("B6").Resize(k, C).Value = Res
                    Ws.Range("D6").CurrentRegion.Borders.LineStyle = 1
                    Ws.Range("D6").CurrentRegion.EntireColumn.AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub
Dữ liệu chạy thử không ra hết rồi bạn ơi, còn định dạng font chữ, số vs kích thước cột không giống sheet ban đầu. thấy code của bạn Hoàng Tuấn 868 khá ổn á.
 
Dữ liệu chạy thử không ra hết rồi bạn ơi, còn định dạng font chữ, số vs kích thước cột không giống sheet ban đầu. thấy code của bạn Hoàng Tuấn 868 khá ổn á.
Lẽ ra bạn cảm ơn người đã hỗ trợ bạn trước thì vui hơn. Còn muốn giữ nguyên định dạng các thứ thì tham khảo thêm code này:
Mã:
Sub ABC()
    Dim Dic As Object, Ws As Worksheet, iR&, sArr(), i&, Key, S, Rng As Range
    Set Ws = Sheets("TH")
    Set Dic = CreateObject("scripting.dictionary")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    With Ws
        iR = .Range("C" & Rows.Count).End(3).Row
        sArr = .Range("C6:C" & iR).value
        For i = 1 To UBound(sArr)
            Dic(sArr(i, 1)) = Dic(sArr(i, 1)) & "|" & i + 5
        Next
    End With
    For Each Key In Dic.keys
        S = Split(Dic(Key), "|")
        Ws.Copy after:=Ws
        ActiveSheet.Name = Key
        With Sheets(Key)
            For i = 6 To iR
                If Not IsInArray(CStr(i), S) Then
                    If Rng Is Nothing Then
                        Set Rng = .Rows(i)
                    Else
                        Set Rng = Union(Rng, .Rows(i))
                    End If
                End If
            Next
            Rng.Delete
            .Cells(6, 2).value = 1
            Set Rng = Nothing
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Function IsInArray(value As Variant, arr As Variant) As Boolean
    Dim i&
    IsInArray = False
    For i = LBound(arr) To UBound(arr)
        If arr(i) = value Then
            IsInArray = True
            Exit Function
        End If
    Next
End Function
 
Lần chỉnh sửa cuối:
...
Function IsInArray(value As Variant, arr As Variant) As Boolean
Dim i&
IsInArray = False
For i = LBound(arr) To UBound(arr)
If arr(i) = value Then
IsInArray = True
Exit Function
End If
Next
End Function

Phương pháp dò này cũ rồi. Bi giờ hàm Filter của VBA gọn hơn. Hàm này có thể chạy bằng nhiều luồng cho nên có thể nhanh dơn dò.

Function IsInArr(value As Variant, arr As Variant) As Boolean
IsInArr = UBound(Filter(arr, value)) >= 0
End Function
Chú ý: Function này thì chỉ có một dòng, code của bạn cũng chỉ gọi nó một lần, nhét nó vào dòng thử luôn cho gọn.

Nếu chịu rùa một chút thì để ý code của bạn nó trữ item theo dạng chuỗi, tự dưng tách nó ra thành array để dò. Lý do tại sao không dò theo chuỗi cho khỏe thân
Đổi If Not IsInArray(CStr(i), S) Then
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then

Nhưng túm lại thì code của bạn dùng Dic như vậy chưa hoàn hảo. Lúc cần nạp, bạn nạp vào dic cái key gồm mã & "|" & số. Lúc tra thì chỉ cần Exists.
 
Phương pháp dò này cũ rồi. Bi giờ hàm Filter của VBA gọn hơn. Hàm này có thể chạy bằng nhiều luồng cho nên có thể nhanh dơn dò.

Function IsInArr(value As Variant, arr As Variant) As Boolean
IsInArr = UBound(Filter(arr, value)) >= 0
End Function
Chú ý: Function này thì chỉ có một dòng, code của bạn cũng chỉ gọi nó một lần, nhét nó vào dòng thử luôn cho gọn.

Nếu chịu rùa một chút thì để ý code của bạn nó trữ item theo dạng chuỗi, tự dưng tách nó ra thành array để dò. Lý do tại sao không dò theo chuỗi cho khỏe thân
Đổi If Not IsInArray(CStr(i), S) Then
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then

Nhưng túm lại thì code của bạn dùng Dic như vậy chưa hoàn hảo. Lúc cần nạp, bạn nạp vào dic cái key gồm mã & "|" & số. Lúc tra thì chỉ cần Exists.
Cám ơn chú đã góp ý. Sau khi code xong. Cháu cũng nhận ra có thể thay instr. Mà sợ nó dính trùng ví dụ như 1 và 11 hoặc 12. Cháu xin cám ơn chú vì đã chỉ thêm cho cháu thêm thuật toán khác. Cám ơn chú nhiều ạ
Bài đã được tự động gộp:

Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then
Đoạn này của chú đã giải quyết được vấn đề mà cháu đang lăn tăn.
 
bạn viết pro quá, cám ơn nhiều nhé.
thank bác nhiều.
bạn ơi, file hôm qua mình quên chừa dự phòng tăng số cột nhiều hơn hiện tại, bạn có thể chỉnh lại giùm mình với file mới này không ạ. cám ơn bạn.
Điều chỉnh thì thêm một chút thôi, nhưng do sử dụng tiếng Tây bồi nên bài này không hỗ trợ nữa. Thông cảm nhé.
 
Phương pháp dò này cũ rồi. Bi giờ hàm Filter của VBA gọn hơn. Hàm này có thể chạy bằng nhiều luồng cho nên có thể nhanh dơn dò.

Function IsInArr(value As Variant, arr As Variant) As Boolean
IsInArr = UBound(Filter(arr, value)) >= 0
End Function
Chú ý: Function này thì chỉ có một dòng, code của bạn cũng chỉ gọi nó một lần, nhét nó vào dòng thử luôn cho gọn.

Nếu chịu rùa một chút thì để ý code của bạn nó trữ item theo dạng chuỗi, tự dưng tách nó ra thành array để dò. Lý do tại sao không dò theo chuỗi cho khỏe thân
Đổi If Not IsInArray(CStr(i), S) Then
Thành If InStr("|" & Dic(key) & "|", "|" & CStr(i) & "|") <=0 Then

Nhưng túm lại thì code của bạn dùng Dic như vậy chưa hoàn hảo. Lúc cần nạp, bạn nạp vào dic cái key gồm mã & "|" & số. Lúc tra thì chỉ cần Exists.
Chú cho xin đoạn code mới được không ạ.
Bài đã được tự động gộp:

Lẽ ra bạn cảm ơn người đã hỗ trợ bạn trước thì vui hơn. Còn muốn giữ nguyên định dạng các thứ thì tham khảo thêm code này:
Mã:
Sub ABC()
    Dim Dic As Object, Ws As Worksheet, iR&, sArr(), i&, Key, S, Rng As Range
    Set Ws = Sheets("TH")
    Set Dic = CreateObject("scripting.dictionary")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    With Ws
        iR = .Range("C" & Rows.Count).End(3).Row
        sArr = .Range("C6:C" & iR).value
        For i = 1 To UBound(sArr)
            Dic(sArr(i, 1)) = Dic(sArr(i, 1)) & "|" & i + 5
        Next
    End With
    For Each Key In Dic.keys
        S = Split(Dic(Key), "|")
        Ws.Copy after:=Ws
        ActiveSheet.Name = Key
        With Sheets(Key)
            For i = 6 To iR
                If Not IsInArray(CStr(i), S) Then
                    If Rng Is Nothing Then
                        Set Rng = .Rows(i)
                    Else
                        Set Rng = Union(Rng, .Rows(i))
                    End If
                End If
            Next
            Rng.Delete
            .Cells(6, 2).value = 1
            Set Rng = Nothing
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Function IsInArray(value As Variant, arr As Variant) As Boolean
    Dim i&
    IsInArray = False
    For i = LBound(arr) To UBound(arr)
        If arr(i) = value Then
            IsInArray = True
            Exit Function
        End If
    Next
End Function
cám ơn ạ.
 
Web KT
Back
Top Bottom