Sub XYZ()
Dim sArr(), Res()
Dim sRow&, i&, thu&, thu2&, chi&, chi2&, ngay$, phieu$
Dim mPT$, mPTCT$, mPC$, mPCCT$
Application.ScreenUpdating = False
With Sheets("Sheet1")
i = .Range("B" & Rows.Count).End(xlUp).Row
.Range("H2") = 1
.Range("H2:H" & i).DataSeries
.Range("B2:I" & i).Sort .Range("B2"), 1, .Range("C2"), , 1, Header:=xlNo
sArr = .Range("B1:G" & i).Value
sRow = UBound(sArr)
ReDim Res(2 To sRow, 1 To 1)
For i = 2 To sRow
If sArr(i, 2) = Empty Then
If Mid(sArr(i, 5), 1, 3) = "111" Then
thu = thu + 1
Res(i, 1) = "PT" & Format(sArr(i, 1), "DDMMYY.") & thu
mPT = Res(i, 1)
ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
chi = chi + 1
Res(i, 1) = "PC" & Format(sArr(i, 1), "DDMMYY.") & chi
mPC = Res(i, 1)
End If
Else
If sArr(i, 1) <> sArr(i - 1, 1) Or sArr(i, 2) <> sArr(i - 1, 2) Then
If Mid(sArr(i, 5), 1, 3) = "111" Then
thu2 = thu2 + 1
Res(i, 1) = "PTCT" & Format(sArr(i, 1), "DDMMYY.") & thu2
mPTCT = Res(i, 1)
ElseIf Mid(sArr(i, 6), 1, 3) = "111" Then
chi2 = chi2 + 1
Res(i, 1) = "PCCT" & Format(sArr(i, 1), "DDMMYY.") & chi2
mPCCT = Res(i, 1)
End If
Else
Res(i, 1) = Res(i - 1, 1)
End If
End If
Next i
.Range("A2").Resize(sRow - 1) = Res
.Range("A2:I" & i).Sort .Range("H2"), 1, Header:=xlNo
.Range("H2").Resize(sRow - 1) = Empty
End With
Application.ScreenUpdating = True
End Sub