Sub TachDL_GPE()
Dim Endr As Long, Dic As Object, i As Long, Arr(), j As Long
Dim DL(), KQ(), r As Long, k As Long, Sh As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Xoa cac sheet da tao truoc do - chi giu lai sheet So- Lieu va sheet BangMau
Application.DisplayAlerts = False
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "So-Lieu" And Sh.Name <> "BangMau" Then
Sh.Delete
End If
Next
Application.DisplayAlerts = True
With Sheet10
.AutoFilterMode = False
Endr = .Range("B65500").End(xlUp).Row
If Endr > 11 Then
Set Dic = CreateObject("scripting.dictionary")
DL = .Range("B12:E" & Endr)
ReDim KQ(1 To Endr - 11, 1 To 3)
ReDim Arr(1 To Endr - 11, 1 To 5)
For i = 1 To Endr - 11
If Not Dic.Exists(DL(i, 1)) Then
j = j + 1
Dic.Add DL(i, 1), j
KQ(j, 1) = 1
KQ(j, 3) = DL(i, 1)
KQ(j, 2) = Arr
KQ(j, 2)(1, 1) = 1
KQ(j, 2)(1, 2) = DL(i, 1)
KQ(j, 2)(1, 3) = DL(i, 2)
KQ(j, 2)(1, 4) = DL(i, 3)
KQ(j, 2)(1, 5) = DL(i, 4)
Else
r = Dic.Item(DL(i, 1))
k = KQ(r, 1) + 1
KQ(r, 1) = k
KQ(r, 2)(k, 1) = k
KQ(r, 2)(k, 2) = DL(i, 1)
KQ(r, 2)(k, 3) = DL(i, 2)
KQ(r, 2)(k, 4) = DL(i, 3)
KQ(r, 2)(k, 5) = DL(i, 4)
End If
Next i
For i = 1 To j
Sheets("BangMau").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = KQ(i, 3)
.Range("A12").Resize(KQ(i, 1), 5).Value = KQ(i, 2)
End With
Next i
Else
MsgBox "Co du lieu dau ma lam - hehe !", , GPE
End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
