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

huonglien1901 · 4/11/18

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!

Lequocvan · 4/11/18

Em copy và paste code của các Thầy nhé! Có điều nếu danh sách duy nhất mà lọc ra từ cột C (dept) có số lượng lớn sẽ có vấn đề là sẽ có rất nhiều sheet trong file đấy nhé!
Dept
0410
0420
0430
0450
0460
0470
0480
0610
0620
0630
=> chỉ tách ra 11 sheets chứ mà tách ra khoảng trăm sheets thì ôi thôi

snow25 · 4/11/18

huonglien1901 đã viế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!

đây bạn xem nhé

Mã:

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

huonglien1901 · 4/11/18

snow25 đã viết:

đây bạn xem nhé

Mã:

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

Cảm ơn Anh rất nhiều!
Code đúng ý em rồi, nhưng hiện tại sheet tách ra lại là từ lớn tới nhỏ(630------410), nên em muốn sheet tách ra sắp xếp từ nhỏ đến lớn(0410------0630)
nhờ Anh hỗ trợ các sheet tách ra tự động Autofit dòng và cột luôn..

Em cảm ơn Anh rất nhiều!

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

Lequocvan đã viết:
Em copy và paste code của các Thầy nhé! Có điều nếu danh sách duy nhất mà lọc ra từ cột C (dept) có số lượng lớn sẽ có vấn đề là sẽ có rất nhiều sheet trong file đấy nhé!
Dept
0410
0420
0430
0450
0460
0470
0480
0610
0620
0630
=> chỉ tách ra 11 sheets chứ mà tách ra khoảng trăm sheets thì ôi thôi

Dữ liệu chỉ từng đó thôi Anh,
hiện tại Code của Anh các sheet Tách ra mất định dạng hêt Anh,

Lequocvan · 4/11/18

Cách làm của bác snow25 thiệt hay. Cảm ơn Bác.
trong code mà em search được thì chỉ thay đoạn sau: Cells.PasteSpecial Paste:=xlPasteAll 'xlPasteFormats

snow25 · 4/11/18

huonglien1901 đã viết:
Cảm ơn Anh rất nhiều!
Code đúng ý em rồi, nhưng hiện tại sheet tách ra lại là từ lớn tới nhỏ(630------410), nên em muốn sheet tách ra sắp xếp từ nhỏ đến lớn(0410------0630)
nhờ Anh hỗ trợ các sheet tách ra tự động Autofit dòng và cột luôn..

Em cảm ơn Anh rất nhiều!

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

Dữ liệu chỉ từng đó thôi Anh,
hiện tại Code của Anh các sheet Tách ra mất định dạng hêt Anh,

đây nhé bạn

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

Lequocvan đã viết:
Cách làm của bác snow25 thiệt hay. Cảm ơn Bác.
trong code mà em search được thì chỉ thay đoạn sau: Cells.PasteSpecial Paste:=xlPasteAll 'xlPasteFormats

mình học được của các bác trên diễn đàn mà.

♫ђöล♥ßล†♥†µ♫ · 4/11/18

snow25 đã viết:
đây nhé bạn

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

mình học được của các bác trên diễn đàn mà.

Em tải file đính kèm thấy lỗi ngay tại ws.Name = arr(i, 3)

snow25 · 4/11/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Em tải file đính kèm thấy lỗi ngay tại ws.Name = arr(i, 3)

à cái này là lỗi đặt tên sheets nó có rồi ko đặt được nữa nếu cần thì phải kiểm tra xem sheets đã tồn tại chưa

huonglien1901 · 4/11/18

snow25 đã viết:
đây nhé bạn

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

mình học được của các bác trên diễn đàn mà.

Em nhờ anh khi tách sheet thì xóa sheet cũ đi,

Em cảm ơn Anh!

snow25 · 4/11/18

huonglien1901 đã viết:
Em nhờ anh khi tách sheet thì xóa sheet cũ đi,

Em cảm ơn Anh!

đây bạn xem nhé

huonglien1901 · 4/11/18

snow25 đã viết:
đây bạn xem nhé

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.

huonglien1901 · 4/11/18

Em có code này mà khi tách sheet lại mất định dạng, Nhờ Anh @snow25 hỗ trợ giúp em.

PHP:

Option Explicit
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal SearchText As String, ByVal HasTitle As Boolean)
  Dim aTmp, arr, dic, aKey
  Dim lR As Long, lC As Long, dTmpVal As Double
  Dim bChk As Boolean
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmp = SourceArray
  ColIndex = ColIndex + LBound(aTmp, 2) - 1
  bChk = (InStr("><=", Left(SearchText, 1)) > 0)
  For lR = LBound(aTmp, 1) - HasTitle To UBound(aTmp, 1)
    If bChk And SearchText <> "" Then
      dTmpVal = CDbl(aTmp(lR, ColIndex))
      If Evaluate(dTmpVal & SearchText) Then dic.Add lR, ""
    Else
      If Left(SearchText, 1) = "!" Then
        If Not (UCase(aTmp(lR, ColIndex)) Like UCase(Mid(SearchText, 2, Len(SearchText)))) Then dic.Add lR, ""
      Else
        If UCase(aTmp(lR, ColIndex)) Like UCase(SearchText) Then dic.Add lR, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    aKey = dic.Keys
    ReDim arr(LBound(aTmp, 1) To UBound(aKey) + LBound(aTmp, 1) - HasTitle, LBound(aTmp, 2) To UBound(aTmp, 2))
    For lR = LBound(aTmp, 1) - HasTitle To UBound(aKey) + LBound(aTmp, 1) - HasTitle
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(lR, lC) = aTmp(aKey(lR - LBound(aTmp, 1) + HasTitle), lC)
      Next
    Next
    If HasTitle Then
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(LBound(aTmp, 1), lC) = aTmp(LBound(aTmp, 1), lC)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Worksheets(SheetName) Is Nothing
End Function
Sub Main()
  Dim aSrc, aRes
  Dim wks As Worksheet, wksSrc As Worksheet, dic As Object
  Dim SheetName As String
  Dim lR As Long, lCount As Long
  Set wksSrc = Worksheets("Sheet1")
  aSrc = wksSrc.Range("A1:N100000")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  Application.ScreenUpdating = False
  For lR = 2 To UBound(aSrc, 1)
    SheetName = CStr(aSrc(lR, 3))
    If Len(SheetName) Then
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, lR
        If Not SheetExists(SheetName) Then
          lCount = lCount + 1
          With Worksheets.Add(After:=Worksheets(lCount))
            .Name = SheetName
            .Tab.Color = vbRed
          End With
        Else
          Worksheets(SheetName).Tab.Color = False
        End If
        Set wks = Worksheets(SheetName)
        aRes = Filter2DArray(aSrc, 3, SheetName, True)
        wks.Range("A1").Resize(UBound(aRes, 1), 14).Value = aRes
      End If
    End If
  Next
  wksSrc.Select
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

snow25 · 4/11/18

huonglien1901 đã viết:

Em có code này mà khi tách sheet lại mất định dạng, Nhờ Anh @snow25 hỗ trợ giúp em.

PHP:

Option Explicit
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal SearchText As String, ByVal HasTitle As Boolean)
  Dim aTmp, arr, dic, aKey
  Dim lR As Long, lC As Long, dTmpVal As Double
  Dim bChk As Boolean
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmp = SourceArray
  ColIndex = ColIndex + LBound(aTmp, 2) - 1
  bChk = (InStr("><=", Left(SearchText, 1)) > 0)
  For lR = LBound(aTmp, 1) - HasTitle To UBound(aTmp, 1)
    If bChk And SearchText <> "" Then
      dTmpVal = CDbl(aTmp(lR, ColIndex))
      If Evaluate(dTmpVal & SearchText) Then dic.Add lR, ""
    Else
      If Left(SearchText, 1) = "!" Then
        If Not (UCase(aTmp(lR, ColIndex)) Like UCase(Mid(SearchText, 2, Len(SearchText)))) Then dic.Add lR, ""
      Else
        If UCase(aTmp(lR, ColIndex)) Like UCase(SearchText) Then dic.Add lR, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    aKey = dic.Keys
    ReDim arr(LBound(aTmp, 1) To UBound(aKey) + LBound(aTmp, 1) - HasTitle, LBound(aTmp, 2) To UBound(aTmp, 2))
    For lR = LBound(aTmp, 1) - HasTitle To UBound(aKey) + LBound(aTmp, 1) - HasTitle
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(lR, lC) = aTmp(aKey(lR - LBound(aTmp, 1) + HasTitle), lC)
      Next
    Next
    If HasTitle Then
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(LBound(aTmp, 1), lC) = aTmp(LBound(aTmp, 1), lC)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Worksheets(SheetName) Is Nothing
End Function
Sub Main()
  Dim aSrc, aRes
  Dim wks As Worksheet, wksSrc As Worksheet, dic As Object
  Dim SheetName As String
  Dim lR As Long, lCount As Long
  Set wksSrc = Worksheets("Sheet1")
  aSrc = wksSrc.Range("A1:N100000")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  Application.ScreenUpdating = False
  For lR = 2 To UBound(aSrc, 1)
    SheetName = CStr(aSrc(lR, 3))
    If Len(SheetName) Then
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, lR
        If Not SheetExists(SheetName) Then
          lCount = lCount + 1
          With Worksheets.Add(After:=Worksheets(lCount))
            .Name = SheetName
            .Tab.Color = vbRed
          End With
        Else
          Worksheets(SheetName).Tab.Color = False
        End If
        Set wks = Worksheets(SheetName)
        aRes = Filter2DArray(aSrc, 3, SheetName, True)
        wks.Range("A1").Resize(UBound(aRes, 1), 14).Value = aRes
      End If
    End If
  Next
  wksSrc.Select
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

mình không biết nhé

đây là code tách theo mảng nó còn mỗi giá trị value thôi.mình đoán là vậy.

vanthinh3101 · 4/11/18

huonglien1901 đã viết:

Em có code này mà khi tách sheet lại mất định dạng, Nhờ Anh @snow25 hỗ trợ giúp em.

PHP:

Option Explicit
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal SearchText As String, ByVal HasTitle As Boolean)
  Dim aTmp, arr, dic, aKey
  Dim lR As Long, lC As Long, dTmpVal As Double
  Dim bChk As Boolean
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmp = SourceArray
  ColIndex = ColIndex + LBound(aTmp, 2) - 1
  bChk = (InStr("><=", Left(SearchText, 1)) > 0)
  For lR = LBound(aTmp, 1) - HasTitle To UBound(aTmp, 1)
    If bChk And SearchText <> "" Then
      dTmpVal = CDbl(aTmp(lR, ColIndex))
      If Evaluate(dTmpVal & SearchText) Then dic.Add lR, ""
    Else
      If Left(SearchText, 1) = "!" Then
        If Not (UCase(aTmp(lR, ColIndex)) Like UCase(Mid(SearchText, 2, Len(SearchText)))) Then dic.Add lR, ""
      Else
        If UCase(aTmp(lR, ColIndex)) Like UCase(SearchText) Then dic.Add lR, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    aKey = dic.Keys
    ReDim arr(LBound(aTmp, 1) To UBound(aKey) + LBound(aTmp, 1) - HasTitle, LBound(aTmp, 2) To UBound(aTmp, 2))
    For lR = LBound(aTmp, 1) - HasTitle To UBound(aKey) + LBound(aTmp, 1) - HasTitle
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(lR, lC) = aTmp(aKey(lR - LBound(aTmp, 1) + HasTitle), lC)
      Next
    Next
    If HasTitle Then
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(LBound(aTmp, 1), lC) = aTmp(LBound(aTmp, 1), lC)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Worksheets(SheetName) Is Nothing
End Function
Sub Main()
  Dim aSrc, aRes
  Dim wks As Worksheet, wksSrc As Worksheet, dic As Object
  Dim SheetName As String
  Dim lR As Long, lCount As Long
  Set wksSrc = Worksheets("Sheet1")
  aSrc = wksSrc.Range("A1:N100000")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  Application.ScreenUpdating = False
  For lR = 2 To UBound(aSrc, 1)
    SheetName = CStr(aSrc(lR, 3))
    If Len(SheetName) Then
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, lR
        If Not SheetExists(SheetName) Then
          lCount = lCount + 1
          With Worksheets.Add(After:=Worksheets(lCount))
            .Name = SheetName
            .Tab.Color = vbRed
          End With
        Else
          Worksheets(SheetName).Tab.Color = False
        End If
        Set wks = Worksheets(SheetName)
        aRes = Filter2DArray(aSrc, 3, SheetName, True)
        wks.Range("A1").Resize(UBound(aRes, 1), 14).Value = aRes
      End If
    End If
  Next
  wksSrc.Select
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

Bạn thử xem

PHP:

Sub Split_files()
    Dim sArr(), dArr(), Dic As Object, Tmp, Ws As Worksheet
    Dim I As Long, J As Long, K As Long, Col As Long, Header As Range
    
    Application.ScreenUpdating = False
    Set Header = Sheet1.Range("A1:N1")
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 14).Value
    
    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 3)) Then Dic.Add sArr(I, 3), ""
    Next I
    
    Tmp = Dic.keys
    For J = LBound(Tmp) To UBound(Tmp)
        K = 0: ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 3) = Tmp(J) Then
                K = K + 1
                For Col = 1 To UBound(sArr, 2)
                    dArr(K, Col) = sArr(I, Col)
                Next Col
            End If
        Next I
        Set Ws = Sheets.Add(, Sheets(Sheets.Count))
        With Ws
            .Name = Tmp(J)
            Header.Copy .Range("A1")
            .Range("B:D,F:F,K:K").NumberFormat = "@"
            .Range("A2").Resize(K, UBound(sArr, 2)) = dArr
            .Range("A1").CurrentRegion.EntireColumn.AutoFit
            .Range("A1").CurrentRegion.Borders.LineStyle = 1
        End With
        Erase dArr
    Next J
    Set Header = Nothing: Set Dic = Nothing
    Application.ScreenUpdating = False
    MsgBox "Done", vbInformation, "GPE"
End Sub

Chúc thành công.

be_09 · 4/11/18

huonglien1901 đã viế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!

Dùng thử File này, muốn sửa nội dung gì ở tiêu đề của các sheet tách ra thì vào sheet Mau mà sửa.

huonglien1901 · 5/11/18

vanthinh3101 đã viết:

Bạn thử xem

PHP:

Sub Split_files()
    Dim sArr(), dArr(), Dic As Object, Tmp, Ws As Worksheet
    Dim I As Long, J As Long, K As Long, Col As Long, Header As Range
   
    Application.ScreenUpdating = False
    Set Header = Sheet1.Range("A1:N1")
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr() = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, 14).Value
   
    For I = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(I, 3)) Then Dic.Add sArr(I, 3), ""
    Next I
   
    Tmp = Dic.keys
    For J = LBound(Tmp) To UBound(Tmp)
        K = 0: ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 3) = Tmp(J) Then
                K = K + 1
                For Col = 1 To UBound(sArr, 2)
                    dArr(K, Col) = sArr(I, Col)
                Next Col
            End If
        Next I
        Set Ws = Sheets.Add(, Sheets(Sheets.Count))
        With Ws
            .Name = Tmp(J)
            Header.Copy .Range("A1")
            .Range("B:D,F:F,K:K").NumberFormat = "@"
            .Range("A2").Resize(K, UBound(sArr, 2)) = dArr
            .Range("A1").CurrentRegion.EntireColumn.AutoFit
            .Range("A1").CurrentRegion.Borders.LineStyle = 1
        End With
        Erase dArr
    Next J
    Set Header = Nothing: Set Dic = Nothing
    Application.ScreenUpdating = False
    MsgBox "Done", vbInformation, "GPE"
End Sub

Chúc thành công.

Em cảm ơn Anh !
Nhưng trường hợp em sửa số liệu ở cột C(Dept) thì nó báo lỗi.

huonglien1901 · 5/11/18

be09 đã viết:
Dùng thử File này, muốn sửa nội dung gì ở tiêu đề của các sheet tách ra thì vào sheet Mau mà sửa.

Em cảm ơn Anh rất nhiều!

chúc Anh ngày vui!

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

PHP:

Option Explicit
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal SearchText As String, ByVal HasTitle As Boolean)
  Dim aTmp, arr, dic, aKey
  Dim lR As Long, lC As Long, dTmpVal As Double
  Dim bChk As Boolean
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmp = SourceArray
  ColIndex = ColIndex + LBound(aTmp, 2) - 1
  bChk = (InStr("><=", Left(SearchText, 1)) > 0)
  For lR = LBound(aTmp, 1) - HasTitle To UBound(aTmp, 1)
    If bChk And SearchText <> "" Then
      dTmpVal = CDbl(aTmp(lR, ColIndex))
      If Evaluate(dTmpVal & SearchText) Then dic.Add lR, ""
    Else
      If Left(SearchText, 1) = "!" Then
        If Not (UCase(aTmp(lR, ColIndex)) Like UCase(Mid(SearchText, 2, Len(SearchText)))) Then dic.Add lR, ""
      Else
        If UCase(aTmp(lR, ColIndex)) Like UCase(SearchText) Then dic.Add lR, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    aKey = dic.Keys
    ReDim arr(LBound(aTmp, 1) To UBound(aKey) + LBound(aTmp, 1) - HasTitle, LBound(aTmp, 2) To UBound(aTmp, 2))
    For lR = LBound(aTmp, 1) - HasTitle To UBound(aKey) + LBound(aTmp, 1) - HasTitle
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(lR, lC) = aTmp(aKey(lR - LBound(aTmp, 1) + HasTitle), lC)
      Next
    Next
    If HasTitle Then
      For lC = LBound(aTmp, 2) To UBound(aTmp, 2)
        arr(LBound(aTmp, 1), lC) = aTmp(LBound(aTmp, 1), lC)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Worksheets(SheetName) Is Nothing
End Function
Sub Main()
  Dim aSrc, aRes
  Dim wks As Worksheet, wksSrc As Worksheet, dic As Object
  Dim SheetName As String
  Dim lR As Long, lCount As Long
  Set wksSrc = Worksheets("Sheet1")
  aSrc = wksSrc.Range("A1:N100000")
  Set dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  Application.ScreenUpdating = False
  For lR = 2 To UBound(aSrc, 1)
    SheetName = CStr(aSrc(lR, 3))
    If Len(SheetName) Then
      If Not dic.Exists(SheetName) Then
        dic.Add SheetName, lR
        If Not SheetExists(SheetName) Then
          lCount = lCount + 1
          With Worksheets.Add(After:=Worksheets(lCount))
            .Name = SheetName
            .Tab.Color = vbBlue
          End With
        Else
          Worksheets(SheetName).Tab.Color = False
        End If
        Set wks = Worksheets(SheetName)
        aRes = Filter2DArray(aSrc, 3, SheetName, True)
        wks.Range("A1").Resize(UBound(aRes, 1), 14).Value = aRes
        wks.Range("B:D,F:F,K:K").NumberFormat = "@"
        wks.Range("A1").CurrentRegion.EntireColumn.AutoFit
        wks.Range("A1").CurrentRegion.Borders.LineStyle = 1
      End If
    End If
  Next
  wksSrc.Select
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

Em có mượn code của Thầy @ndu96081631 nhưng khi chỉnh lại số liệu thì code không chạy.
Ý là em giảm số dòng đi, thì khi tách dữ liệu thì các sheet đã tách chỉ chạy như những dữ liệu đầu tiên,

Em nhờ mọi người hỗ trợ.

Em cảm ơn nhiều!

vanthinh3101 · 5/11/18

huonglien1901 đã viết:
Em cảm ơn Anh !
Nhưng trường hợp em sửa số liệu ở cột C(Dept) thì nó báo lỗi.
View attachment 207018

Bạn phải xóa bỏ các sheet đã tách trước đó đi.
Hệ thống báo không thể đặt tên Sheet mới trùng với tên Sheet đang tồn tại rồi.

huonglien1901 · 5/11/18

vanthinh3101 đã viết:
Bạn phải xóa bỏ các sheet đã tách trước đó đi.
Hệ thống báo không thể đặt tên Sheet mới trùng với tên Sheet đang tồn tại rồi.

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!

Quang_Hải · 5/11/18

huonglien1901 đã viế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!

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

Mã:

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

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

GPE là ngôi nhà thứ 2 của tôi!!!

File đính kèm

Thành viên thường trực

File đính kèm

Thành viên gạo cội

File đính kèm

GPE là ngôi nhà thứ 2 của tôi!!!

Thành viên thường trực

Thành viên gạo cội

File đính kèm

Thành viên tiêu biểu

Thành viên gạo cội

GPE là ngôi nhà thứ 2 của tôi!!!

Thành viên gạo cội

File đính kèm

GPE là ngôi nhà thứ 2 của tôi!!!

GPE là ngôi nhà thứ 2 của tôi!!!

File đính kèm

Thành viên gạo cội

Thành viên tích cực

Biên Hòa, Đồng Nai

File đính kèm

GPE là ngôi nhà thứ 2 của tôi!!!

GPE là ngôi nhà thứ 2 của tôi!!!

Thành viên tích cực

GPE là ngôi nhà thứ 2 của tôi!!!

Thành viên gạo cội

Đếm ngược thời gian