Tách sheet tổng hợp thành những sheet nhỏ theo điều kiện

[huonglien1901]

Em chào mọi người!

Em có vấn đề nhờ hỗ trợ.

Em muốn từ file tổng hợp tách thành những sheet theo điều kiện cột C(Dept)

khi Tách xong thì giữ nguyên định dạng giống file tổng.

Em cảm ơn mọi người nhiều!

 

[snow25]

Em cảm ơn Anh!
mà hình như code của anh chưa tự động (fix dòng và fix cột) trong những sheet đã tách.

đây bạn xem nhé

Sub tachshets()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim arr, Ws As Worksheet
Dim sh As Worksheet
Dim I As Long, a As Long, b As Long
Dim Dic As Object
For Each sh In Application.Sheets
  If sh.Name <> "Sheet1" Then
     sh.Delete
  End If
Next
Set Dic = CreateObject("scripting.dictionary")
b = 1
With Sheet1
    arr = .Range("a2:N" & .Range("c" & Rows.Count).End(xlUp).Row).Value
    a = UBound(arr, 1)
    .Range("p1").Value = .Range("c1").Value
    For I = 1 To a
        If Not Dic.exists(arr(I, 3)) Then
           Dic.Add arr(I, 3), ""
        .Range("p2").Value = arr(I, 3)
        b = Sheets.Count
        Set Ws = Worksheets.Add(, Sheets(b))
        Ws.Name = arr(I, 3)
         .Range("A1:n" & a).AdvancedFilter Action:=xlFilterCopy, Criteriarange:=.Range("p1:p2"), copytorange:=Ws.Range("A1:n1")
          Ws.Range("A1").CurrentRegion.EntireColumn.AutoFit
         End If
    Next I
   .Range("p1:p2").ClearContents
End With
 Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[Ba Tê]

Em chào mọi người!

Em có vấn đề nhờ hỗ trợ.

Em muốn từ file tổng hợp tách thành những sheet theo điều kiện cột C(Dept)

khi Tách xong thì giữ nguyên định dạng giống file tổng.

Em cảm ơn mọi người nhiều!

Muốn giữ nguyên định dạng thì Copy Sheet.
Lấy dữ liệu cần lấy xong, xóa các dòng thừa.
Mà không biết tách để làm gì, nếu chỉ xem thì Filter cột C là xong.

 

[vanthinh3101]

Nhờ Anh có thể viết giúp em code xoá các sheet tách được không Anh?

Em cảm ơn Anh nhiều!

Bạn xem bài #21, có 1 đoạn xóa Sheet cũ đấy.
Bạn lồng thêm vào code của tôi là được.

 

[huonglien1901]

đây bạn xem nhé

Sub tachshets()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim arr, Ws As Worksheet
Dim sh As Worksheet
Dim I As Long, a As Long, b As Long
Dim Dic As Object
For Each sh In Application.Sheets
  If sh.Name <> "Sheet1" Then
     sh.Delete
  End If
Next
Set Dic = CreateObject("scripting.dictionary")
b = 1
With Sheet1
    arr = .Range("a2:N" & .Range("c" & Rows.Count).End(xlUp).Row).Value
    a = UBound(arr, 1)
    .Range("p1").Value = .Range("c1").Value
    For I = 1 To a
        If Not Dic.exists(arr(I, 3)) Then
           Dic.Add arr(I, 3), ""
        .Range("p2").Value = arr(I, 3)
        b = Sheets.Count
        Set Ws = Worksheets.Add(, Sheets(b))
        Ws.Name = arr(I, 3)
         .Range("A1:n" & a).AdvancedFilter Action:=xlFilterCopy, Criteriarange:=.Range("p1:p2"), copytorange:=Ws.Range("A1:n1")
          Ws.Range("A1").CurrentRegion.EntireColumn.AutoFit
         End If
    Next I
   .Range("p1:p2").ClearContents
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Em cảm ơn Anh nhiều!

Bài đã được tự động gộp: 5/11/18

Muốn giữ nguyên định dạng thì Copy Sheet.
Lấy dữ liệu cần lấy xong, xóa các dòng thừa.
Mà không biết tách để làm gì, nếu chỉ xem thì Filter cột C là xong.

Em cảm ơn Bác nhiều!

Chúc Bác một buổi tối vui vẻ!

Bài đã được tự động gộp: 5/11/18

Thử cách viết này xem sao

Sub Tach_Ra()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Data(), DataLoc As Range, i As Long, Dept()
Dim Dic As Object, sh As Worksheet
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
   Data = .Range(.[A2], .[A65536].End(3)).Resize(, 3).Value
   Set DataLoc = .Range(.[A1], .[A65536].End(3)).Resize(, 14)
End With
For i = 1 To UBound(Data)
   If Not Dic.exists(Data(i, 3)) Then Dic.Add Data(i, 3), ""
Next
Dept = Dic.keys
Dic.RemoveAll
For Each sh In ThisWorkbook.Worksheets
   Dic.Add sh.Name, Empty
Next

For i = 0 To UBound(Dept)
   If Dic.exists(Dept(i)) Then Sheets(Dept(i)).Delete
   With DataLoc
      .AutoFilter 3, Dept(i)
      .SpecialCells(12).Copy
      Sheets.Add After:=Sheets(Sheets.Count)
      With ActiveSheet
         .Name = Dept(i)
         .[A1].PasteSpecial 1
         .[A:N].Columns.AutoFit
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Em cảm ơn Anh nhiều!

Nhiều cách làm hay quá.
chúc anh nhiều niềm vui.

 

[quangthy]

đây bạn xem nhé

Sub tachshets()
Application.ScreenUpdating = False
Dim arr, ws As Worksheet
Dim i As Long, a As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("a2:N" & .Range("c" & Rows.Count).End(xlUp).Row).Value
    a = UBound(arr, 1)
    .Range("p1").Value = .Range("c1").Value
    For i = 1 To a
        If Not dic.exists(arr(i, 3)) Then
           dic.Add arr(i, 3), ""
        .Range("p2").Value = arr(i, 3)
        Set ws = Worksheets.Add(, Sheet1)
        ws.Name = arr(i, 3)
         .Range("A1:n" & a).AdvancedFilter Action:=xlFilterCopy, Criteriarange:=.Range("p1:p2"), copytorange:=ws.Range("A1:n1"), unique:=False
         End If
    Next i
   .Range("p1:p2").ClearContents
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub

Cho em hỏi , theo code là tách cột "c" trường hợp em muốn thay doi thì áp dung như thế nào (VD em chay theo cot D)
EM VIET LẠI VÀ NÓ KHÔNG CHẠY

Sub TACH()
Application.ScreenUpdating = False
Dim arr, ws As Worksheet
Dim i As Long, a As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
arr = .Range("a2:ab" & .Range("d" & Rows.Count).End(xlUp).Row).Value
a = UBound(arr, 1)
.Range("p1").Value = .Range("d1").Value
For i = 1 To a
If Not dic.exists(arr(i, 3)) Then
dic.Add arr(i, 3), ""
.Range("p2").Value = arr(i, 3)
Set ws = Worksheets.Add(, Sheet1)
ws.Name = arr(i, 3)
.Range("A1:ab" & a).AdvancedFilter Action:=xlFilterCopy, Criteriarange:=.Range("p12"), copytorange:=ws.Range("A1:ab1"), unique:=False
End If
Next i
.Range("p12").ClearContents
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub

 

[huonglien1901]

Cho em hỏi , theo code là tách cột "c" trường hợp em muốn thay doi thì áp dung như thế nào (VD em chay theo cot D)
EM VIET LẠI VÀ NÓ KHÔNG CHẠY

Sub TACH()
Application.ScreenUpdating = False
Dim arr, ws As Worksheet
Dim i As Long, a As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
arr = .Range("a2:ab" & .Range("d" & Rows.Count).End(xlUp).Row).Value
a = UBound(arr, 1)
.Range("p1").Value = .Range("d1").Value
For i = 1 To a
If Not dic.exists(arr(i, 3)) Then
dic.Add arr(i, 3), ""
.Range("p2").Value = arr(i, 3)
Set ws = Worksheets.Add(, Sheet1)
ws.Name = arr(i, 3)
.Range("A1:ab" & a).AdvancedFilter Action:=xlFilterCopy, Criteriarange:=.Range("p12"), copytorange:=ws.Range("A1:ab1"), unique:=False
End If
Next i
.Range("p12").ClearContents
End With
Set dic = Nothing
Application.ScreenUpdating = True
End Sub

Bạn viết sai rồi. Phải viết là Arr(i,4).
Bạn đưa file lên rồi cho dễ hình dung