Sub ABC()
Dim arr(), c(), res(), sRow&, sCol&, i&, j&, pha&, k&
Const cp As Long = 9 'Toi da 9 Phase
arr = Range("B2:F" & Range("B1000000").End(xlUp).Row).Value
sRow = UBound(arr): sCol = UBound(arr, 2)
ReDim res(1 To sRow * sCol, 1 To cp + 2)
For j = 2 To sCol
ReDim c(0 To cp)
For i = 2 To sRow
If arr(i, j) <> Empty Then
pha = Right(arr(i, j), 1)
c(pha) = c(pha) + 1
res(k + c(pha), 1) = k + c(pha)
res(k + c(pha), 2) = arr(1, j)
res(k + c(pha), pha + 2) = arr(i, 1)
If c(0) < c(pha) Then c(0) = c(pha)
End If
Next i
k = k + c(0)
Next j
Range("H3").Resize(UBound(res), cp + 2) = res
End Sub