Code tach 1 sheet tổng hợp ra cách sheet khac trong cùng 1 file

Sub TachNhom()

Dim myCell As Range
    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim TempWks As Worksheet
    Dim rsp As Integer
    Dim i As Long

    Const TopLeftCellOfDataBase As String = “A4”
    Const KeyColumn As String = “C”
    ‘muon tach cot nao thi dien ten cot do
 

    Set DataBaseWks = Worksheets(“DATA”)
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row – 1

    Set TempWks = Worksheets.Add

    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                            .Cells.SpecialCells(xlCellTypeLastCell))
    End With

    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=TempWks.Range(“A1”), _
            Unique:=True

        TempWks.Range(“D1“).Value = _
            .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With

    With TempWks
        Set ListRange = .Range(“A2”, .Cells(.Rows.Count, “A”).End(xlUp))
    End With

    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With

    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox “Please rename: ” & wks.Name
                Err.Clear
             
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If

        If rsp = 6 Then
          DataBaseWks.Rows(“1:” & i).Copy Destination:=wks.Range(“A1”)
        End If
     
        TempWks.Range(“D2”).Value = “=” & Chr(34) & “=” & myCell.Value & Chr(34)

        If rsp = 6 Then
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range(“D1:D2”), _
              CopyToRange:=wks.Range(“A1”).Offset(i, 0), _
              Unique:=False
        Else
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range(“D1:D2”), _
              CopyToRange:=wks.Range(“A1”), _
              Unique:=False
              Columns(“D:D”).ColumnWidth = 20
              Columns(“F:F”).ColumnWidth = 20
              Columns(“G:G”).ColumnWidth = 15
        End If
     
    Next myCell
 
    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox “TÁCH  THÀNH  CÔNG”

End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

———————

code tách các sheet ra thành nhiều file tại 1 forder

Sub tachsheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & sh.Name, 51

' Có thể đổi lại vị trí lư tại chỗ ""
    ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub