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

Chia sẻ bởi:hands

★★★★★

‹ Dùng Macro 4 để lấy dữ liệu... Lọc dữ liệu thỏa mãn điều kiện ›

Quảng cáo

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 Brand ạ
Em cảm ơn ạ

Dùng tạm code này.

Option Explicit

Sub Tach1SheetThanhNhieuSheet()
Dim tTime As Double

Dim Ws As Worksheet
Dim i As Integer
Dim NWs As Worksheet
Dim Odau As Range

'tTime = Timer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'XOA
 For Each Ws In ActiveWorkbook.Sheets
    If Ws.Name <> "Sheet1" Then Ws.Delete
Next
Set Ws = ThisWorkbook.Sheets("Sheet1")

Ws.Columns(3).Copy
    Ws.Columns(17).PasteSpecial xlPasteValues
    Ws.Cells(2, 17).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes

' Loc cac Đk va tao sheet moi và copy
    i = 2
    While (Ws.Cells(i, 17) <> "")
    Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set NWs = ActiveSheet
    NWs.Name = Ws.Cells(i, 17)
    Ws.Select
    Set Odau = Ws.Range("A1")
    Odau.CurrentRegion.AutoFilter Field:=3, Criteria1:=Ws.Cells(i, 17)
    Odau.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    NWs.Range("A1").PasteSpecial
    NWs.Cells.EntireColumn.AutoFit
    Ws.Select
    Odau.AutoFilter
    i = i + 1
    Wend
    Application.DisplayAlerts = True

Application.ScreenUpdating = True
    Ws.Columns(17).ClearContents
'Debug.Print Timer - tTime

MsgBox " Đa hoàn thành"
End Sub

www.giaiphapexcel.com/diendan/threads/t%C3%A1ch-1-sheet-th%C3%A0nh-nhi%E1%BB%81u-sheet-theo-%C4%91i%E1%BB%81u-ki%E1%BB%87n.162956/

Góp vui thế này:

Sub Tach_Sheets()
    Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 9)
    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 <> "Sheet1" Then
            Ws.Delete
        End If
    Next Ws
    With Sheets("Sheet1")
        Set Rng = .Range("A1:I1")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A2:I" & Lr).Value
        For i = 1 To UBound(Arr)
            If Arr(i, 3) <> "" Then
                Key = Arr(i, 3)
                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 <> "Sheet1" Then
                    For i = 1 To UBound(Arr)
                        If Arr(i, 3) = Ws.Name Then
                            k = k + 1
                            For j = 1 To 9
                                Res(k, j) = Arr(i, j)
                            Next j
                        End If
                    Next i
                End If
                If k Then
                    Rng.Copy Ws.Range("A1")
                    Ws.Range("A2").Resize(k, 9).Value = Res
                    Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                    Ws.Columns("A:I").AutoFit
                    k = 0
                End If
            Next Ws
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done"
End Sub

Dạ, em có nhờ code của anh mà làm được file của em, nhưng trong file của em cần điền thêm chữ "Bên giao" và "Bên nhận" sau mỗi sheet được tách ra (Tính từ dòng cuối có dữ liệu + 2 dòng trống, thì điền Bên giao và Bên nhận ở cột C và F, vì mỗi PO có số lượng sp khác nhau nên không set cố định vào 1 ô được ạ)
Em gửi file đính kèm, nhờ anh hỗ trợ cho em xin code với ạ.
Em cám ơn nhiều

Gì mà làm việc sớm thế, mình còn đang ăn bánh chưng.
Mách cho bạn nhá, sau khi chạy xong đoạn tách sheets thì thêm phần tìm dòng cuối có dữ liệu, gán chữ "Bên giao" và " Bên nhận" vào vị trí cột C, F "ở dòng cuối +2" là được rồi.
Bạn biết chỉnh code thì thêm lệnh nhỏ này chắc tự làm được đấy!