Public Sub GPE()
Dim Dic As Object, sArr(), Ws As Worksheet, i As Integer, Rng1 As Range, Rng2 As Range, n As Long
Application.ScreenUpdating = False
sArr() = Sheets("DS_Khoi6").Range("E5:E" & Sheets("DS_Khoi6").Range("E65000").End(xlUp).Row).Value
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DS_Khoi6")
.Range("N4").Value = .Range("E4").Value
Set Rng1 = .Range("B65000").End(xlUp).Offset(1, 2).Resize(2, 5)
For i = 1 To UBound(sArr, 1)
If Not Dic.exists(sArr(i, 1)) Then
Dic.Add sArr(i, 1), ""
.Range("N5").Value = sArr(i, 1)
Set Ws = Worksheets.Add(, Sheets("DS_Khoi6"))
Ws.Name = sArr(i, 1)
.Range("A4:H" & .Range("E65000").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("N4:N5"), CopyToRange:=Ws.Range("A4:H4"), Unique:=False
Set Rng2 = Ws.Range("B65000").End(xlUp).Offset(1, 2)
Ws.Columns("A:A").ColumnWidth = 6
Ws.Columns("B:B").ColumnWidth = 31.14
Ws.Columns("C:C").ColumnWidth = 12
Ws.Columns("D:G").ColumnWidth = 8
Ws.Columns("H:H").ColumnWidth = 10
n = Ws.Range("A65000").End(xlUp).Row
Ws.Range("A5").Value = 1
Ws.Range("A5").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Stop:=(n - 4), Trend:=False
.Range("A1:H3").Copy Ws.Range("A1")
Rng1.Copy Rng2
End If
Next i
.Range("N4:N5").ClearContents
End With
Dim Wb As Workbook
Sheets(Dic.Keys).Move
Set Wb = ActiveWorkbook
Wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ThisWorkbook.Sheets(1).Name & ".xls", FileFormat:=52
Wb.Close False
Set Dic = Nothing
Application.ScreenUpdating = True
MsgBox "Da xuat xong"
End Sub
