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
