Option Explicit
Sub Tao_file()
On Error Resume Next
Dim Pathname As String, wbname As String, sFoldername As String, CEOfilename As String
Dim Wb As Workbook, tt As Long
Dim ArrFile(), ArrSheet(), Filename
Dim Rng0 As Range, Rng1 As Range, Rng2 As Range
Dim soFile As Integer, soSheet As Integer, j As Long, iRow As Long
Application.ScreenUpdating = False
Frm_Progress.Show
Pathname = ThisWorkbook.Path
With New Scripting.FileSystemObject
For Each Filename In .GetFolder(Pathname & "\Report").Files
Workbooks.Open Filename
wbname = Mid(Filename, InStrRev(Filename, "\") + 1, Len(Filename) - InStrRev(Filename, "\") + 1)
With Workbooks(wbname)
.Activate
With ActiveSheet
.UsedRange.Offset(2).Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlNo
ArrFile = UniArray(Range([a3], [A65536].End(xlUp)))
[COLOR=#008000]'tao cac file mien[/COLOR]
For soFile = 0 To UBound(ArrFile)
.UsedRange.Offset(1).AutoFilter Field:=1, Criteria1:=ArrFile(soFile)
Set Rng0 = .AutoFilter.Range
Set Rng1 = Rng0.Offset(1, 1).Resize(, 1).SpecialCells(xlCellTypeVisible)
ArrSheet = UniArray(Rng1)
soSheet = UBound(ArrSheet) + 1
With Application
.SheetsInNewWorkbook = soSheet
Set Wb = .Workbooks.Add
End With
For j = 0 To soSheet - 1
Rng0.AutoFilter Field:=2, Criteria1:=ArrSheet(j)
Set Rng2 = .AutoFilter.Range
Rng2.Offset(-1, 0).Resize(Rng2.Rows.Count + 1).Copy _
Destination:=Wb.Worksheets("Sheet" & j + 1).Range("A1")
With Wb.Worksheets("Sheet" & j + 1)
.Columns.AutoFit
.Name = ArrSheet(j)
End With
Next
.AutoFilterMode = False
Application.DisplayAlerts = False
sFoldername = "Mien" & Mid(ArrFile(soFile), InStrRev(ArrFile(soFile), "_") + 1, Len(ArrFile(soFile)) - InStrRev(ArrFile(soFile), "_") + 1)
If ExistsFolder(Pathname, sFoldername) = False Then MkDir Pathname & "\" & sFoldername
Wb.SaveAs Filename:=Pathname & "\" & sFoldername & "\" & ArrFile(soFile) & " .xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Wb.Close
Frm_Progress.ProgressBar (soFile / UBound(ArrFile))
Next
[COLOR=#00ff00][/COLOR][COLOR=#008080]'tao file CEO[/COLOR][COLOR=#00ff00]
[/COLOR] ArrSheet = UniArray(Range(.[b3], [b65536].End(xlUp)))
With Application
.SheetsInNewWorkbook = 1
Set Wb = .Workbooks.Add
End With
iRow = .Range("A2").CurrentRegion.Rows.Count
.Range("A2").CurrentRegion.Copy Wb.Sheets("sheet1").Range("A1")
Wb.Sheets("sheet1").Columns.AutoFit
Wb.Sheets("sheet1").Name = .Name
Range("A3:A" & iRow) = Left(wbname, 8) & "_" & .Name
CEOfilename = Left(wbname, 8) & "_" & .Name
For j = 0 To UBound(ArrSheet)
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = ArrSheet(j)
Rng0.AutoFilter Field:=2, Criteria1:=ArrSheet(j)
Set Rng2 = .AutoFilter.Range
Rng2.Offset(-1, 0).Resize(Rng2.Rows.Count + 1).Copy _
Destination:=Worksheets(ArrSheet(j)).Range("A1")
With Worksheets(ArrSheet(j))
.Columns.AutoFit
End With
Next
.AutoFilterMode = False
End With
If ExistsFolder(Pathname, "CEO") = False Then MkDir Pathname & "\" & "CEO"
Wb.SaveAs Filename:=Pathname & "\" & "CEO" & "\" & CEOfilename & " .xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Wb.Close
End With
Workbooks(wbname).Close
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Frm_Progress.Hide
End Sub
[/FONT][FONT="]nên mỗi lần làm là mất 2h-3h, hix 
