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

Hoàng Tuấn 868 · 22/5/24

ttsuong đã viết:
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.

ttsuong · 23/5/24

Hoàng Tuấn 868 đã viết:
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.

dạ =))), thế muốn giữ nguyên định dạng ban đầu ở sheet tổng khi tách ra thì sao ạ

Minh Nhựt7121 · 18/6/24

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 ạ.

Hoàng Tuấn 868 · 18/6/24

Minh Nhựt7121 đã viết:
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 ạ.

Bạn xem thử nhé. .

zzzsxxx01 · 18/6/24

Hoàng Tuấn 868 đã viết:
Bạn xem thử nhé. .

Code bạn viết nhìn gọn quá của mình hơi rắc rối.

Minh Nhựt7121 đã viết:
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 ạ.

Thử tham khảo giải pháp hơi rắc rối này thử nhé

.

Minh Nhựt7121 · 19/6/24

Hoàng Tuấn 868 đã viết:
Bạn xem thử nhé. .

bạn viết pro quá, cám ơn nhiều nhé.

Bài đã được tự động gộp: 19/6/24

zzzsxxx01 đã viết:
Code bạn viết nhìn gọn quá của mình hơi rắc rối.

Thử tham khảo giải pháp hơi rắc rối này thử nhé .

thank bác nhiều.

Minh Nhựt7121 · 19/6/24

Hoàng Tuấn 868 đã viết:
Bạn xem thử nhé. .

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.

HUONGHCKT · 19/6/24

Minh Nhựt7121 đã viết:
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

Minh Nhựt7121 · 19/6/24

HUONGHCKT đã viết:

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 á.

BuiQuangThuan · 19/6/24

Minh Nhựt7121 đã viết:
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

VetMini · 19/6/24

BuiQuangThuan đã viết:
...
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.

BuiQuangThuan · 19/6/24

VetMini đã viết:
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: 19/6/24

VetMini đã viết:
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.

Hoàng Tuấn 868 · 19/6/24

Minh Nhựt7121 đã viết:
bạn viết pro quá, cám ơn nhiều nhé.
thank bác nhiều.

Minh Nhựt7121 đã viết:
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é.

Minh Nhựt7121 · 20/6/24

VetMini đã viết:
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: 20/6/24

BuiQuangThuan đã viết:

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 ạ.

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

Hoàng Tuấn 868

Đăng ký hôm qua

ttsuong

Thành viên mới

Minh Nhựt7121

Thành viên mới

File đính kèm

Hoàng Tuấn 868

Đăng ký hôm qua

File đính kèm

zzzsxxx01

Thành viên chính thức

File đính kèm

Minh Nhựt7121

Thành viên mới

Minh Nhựt7121

Thành viên mới

File đính kèm

HUONGHCKT

Zalo 0986997214

Minh Nhựt7121

Thành viên mới

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

VetMini

Ăn cùng góc phố

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

Hoàng Tuấn 868

Đăng ký hôm qua

Minh Nhựt7121

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian