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

One Response

1. hands says:

   12/03/2023 at 2:23 pm

   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
   
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   'XOA
    For Each Ws In ActiveWorkbook.Sheets
       If Ws.Name <> "REPORT" Then Ws.Delete
   Next
   Set Ws = ThisWorkbook.Sheets("REPORT")
   
   Ws.Range("GT8:GT1000").Copy
       Ws.Cells(1, 217).PasteSpecial xlPasteValues
       Ws.Cells(1, 217).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
   
   ' Loc cac Đk va tao sheet moi và copy
       i = 1
       While (Ws.Cells(i, 217) <> "")
       Worksheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
       Set NWs = ActiveSheet
       NWs.Name = Ws.Cells(i, 217)
       Ws.Select
       Set Odau = Ws.Range("AB7")
       Odau.CurrentRegion.AutoFilter Field:=175, Criteria1:=Ws.Cells(i, 217)
       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(217).ClearContents
       MsgBox " Đa hoàn thành"
   End Sub

   Hoặc dùng code của anh @THÓC SAMA ở bài #3 và sửa lại thế này:

   Option Explicit
   
   Sub Tach_Sheets()
       Dim Lr&, i&, j&, k&, Arr(), Res(1 To 100000, 1 To 187)
       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 <> "REPORT" Then
               Ws.Delete
           End If
       Next Ws
       With Sheets("REPORT")
           Set Rng = .Range("AB7:HF7")
           Lr = .Range("AB" & Rows.Count).End(xlUp).Row
           Arr = .Range("AB8:HF" & Lr).Value
           For i = 1 To UBound(Arr)
               If Arr(i, 175) <> "" Then
                   Key = Arr(i, 175)
                   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 <> "REPORT" Then
                       For i = 1 To UBound(Arr)
                           If Arr(i, 175) = Ws.Name Then
                               k = k + 1
                               For j = 1 To UBound(Arr, 2)
                                   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, UBound(Arr, 2)).Value = Res
                       Ws.Range("A1").CurrentRegion.Borders.LineStyle = 1
                       Ws.Columns("A:GE").AutoFit
                       k = 0
                   End If
               Next Ws
       End With
       Set Dic = Nothing
       Application.ScreenUpdating = True
       Application.DisplayAlerts = True
       MsgBox "Done"
   End Sub

   Cám ơn bác em làm được rồi, tuy nhiên khi em tách file thì nó bị mất các những sheet có sẵn mà chỉ ra sheet tổng hợp và sheet cần tách.
   Bác có thể chỉnh thêm code giúp em, vẫn giữ nguyên các sheet có sẵn trong file được không ạ

   Khi tách dữ liệu ra thành cách sheet Thì điều kiện là

   chia theo Location (cột GT của sheet Report)

   mà cột GT ấy chỉ có là BDO, DNO, HCM và lấy luôn các Location ấy làm tên sheet- và tên sheet chỉ là duy nhất, như vậy các sheet cũ sẽ bị xóa đi thay vào đó là các sheet mới tạo. Nếu giữ lại các sheet có sẵn trong workbook thì khi được dữ liệu tách sẽ được ghi vào đâu? Theo code ở bài #11 thì khi chạy code tất cả các sheet có tên khác "REPORT" đều bị xóa. Nếu bạn muốn giữ lại sheet nào thì:
   Thay dòng code

   If Ws.Name <> "REPORT" Then

   Thành

   If Ws.Name <> "REPORT" or  Ws.Name <> "tên sheet cần giữ" or Ws.Name <> "tên sheet cần giữ" or ....Then

   nếu tên sheet cần giữ mà trùng tên Với Location ở cột GT thì khi Chạy thử, sẽ vấp lỗi Tên sheet không phải là duy nhất.

   Reply