Option Explicit
Sub GPE()
    Dim Arr(), Res(), i&, j&, k&, Lr&, m%, n%, Ws As Worksheet
    Dim V%, XP%, Hnc%, Vm$, Res1(), Res2(), t%
    Dim td1$, td2$, td3$, Rng As Range, sRng As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If InStr(Ws.Name, "T") > 0 Then Ws.Delete
    Next Ws
    On Error Resume Next
    Set Rng = Sheets("SAMPLE").Range("A8:E8")
    Set sRng = Sheets("SAMPLE").Range("A1:D6")
    td2 = "II. Danh s當h nh" & ChrW(7919) & "ng " & ChrW(273) & ChrW(7891) & "ng ch・v" & ChrW(7855) & "ng c・l do"
    td1 = "I. Danh s當h nh" & ChrW(7919) & "ng " & ChrW(273) & ChrW(7891) & "ng ch・v" & ChrW(7855) & "ng khg c・l do"
    td3 = "III. Danh s當h nh" & ChrW(7919) & "ng " & ChrW(273) & ChrW(7891) & "ng ch・xin v" & ChrW(7855) & "ng m" & ChrW(7863) & _
            "t 1/2 bu" & ChrW(7893) & "i"
    With Sheets("NGUON")
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("A6:P" & Lr).Value
        ReDim Res(1 To UBound(Arr) + 3, 1 To 4)
        ReDim Res1(1 To UBound(Arr) + 3, 1 To 4)
        ReDim Res2(1 To UBound(Arr) + 3, 1 To 4)
        For j = 5 To UBound(Arr, 2)
            For i = 2 To UBound(Arr, 1)
                If UCase(Arr(i, j)) = "V" Then
                    V = V + 1: k = k + 1
                    Res(k, 1) = k: Res(k, 2) = Arr(i, 2)
                    Res(k, 3) = Arr(i, 4)
                ElseIf UCase(Arr(i, j)) = "1/2" Then
                    m = m + 1: Hnc = Hnc + 1
                    Res1(m, 1) = m: Res1(m, 2) = Arr(i, 2)
                    Res1(m, 3) = Arr(i, 4)
                ElseIf UCase(Arr(i, j)) = "XP" Then
                    n = n + 1: XP = XP + 1
                    Res2(n, 1) = n: Res2(n, 2) = Arr(i, 2)
                    Res2(n, 3) = Arr(i, 4)
                End If
            Next i
            If Application.Max(k, m, n) > 0 Then
                Worksheets.Add after:=Sheets(Sheets.Count)
                ActiveSheet.Name = "T" & Split(Arr(1, j), " ")(1)
                sRng.Copy Range("A1")
                Range("A7").Value = td1 & " " & V & " " & ChrW(273) & ChrW(7891) & "ng ch・
                Rng.Copy Range("A8"): Range("A7:D8").Font.Bold = True
                Range("A9").Resize(k, 4).Value = Res
                Range("A" & 9 + V).Value = td2 & " " & XP & " " & ChrW(273) & ChrW(7891) & "ng ch・
                Rng.Copy Range("A" & 10 + V)
                Range("A" & 9 + V).Font.Bold = True
                Range("A" & 11 + V).Resize(n, 4).Value = Res2
                Range("A" & 11 + V + XP).Value = td3 & " " & Hnc & " " & ChrW(273) & ChrW(7891) & "ng ch・
                Range("A" & 11 + V + XP).Font.Bold = True
                Rng.Copy Range("A" & 12 + V + XP)
                Range("A" & 13 + V + XP).Resize(m, 4).Value = Res1
                Columns("A:A").ColumnWidth = 5: Columns("B:B").ColumnWidth = 25
                Columns("C:C").ColumnWidth = 25: Columns("D:D").ColumnWidth = 40
                Dim sLr&
                sLr = Range("A" & Rows.Count).End(xlUp).Row
                Range("A7:D" & sLr).Borders.LineStyle = 1
                Range("B" & sLr + 2) = "T" & ChrW(7893) & "ng c" & ChrW(7897) & _
                "ng I+II+III: " & k + m + n & " " & ChrW(273) & ChrW(7891) & "ng ch・
                Range("B" & sLr + 2).Font.Bold = True: Range("B" & sLr + 2).Font.Size = 13
            End If
            k = 0: m = 0: n = 0: V = 0: XP = 0: Hnc = 0
        Next j
    End With
    MsgBox "Done"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub