Sub xyz()
Dim arr(), res(), po$, st$, co$
Dim sRow&, i&, r&, fR&, j&, k&, d&
With Sheets("Data")
i = .Range("K" & Rows.Count).End(xlUp).Row
arr = .Range("D1:AZ" & i + 1).Value
sRow = Application.Count(.Range("D3:AV" & i))
End With
i = UBound(arr, 2)
ReDim res(1 To sRow, 1 To 5)
sRow = UBound(arr) - 1
arr(sRow + 1, 1) = "end"
For i = 3 To sRow
If arr(i, 1) <> Empty Then
po = arr(i, 1): st = arr(i, 3): co = arr(i, 5)
fR = i + 1
End If
If arr(i + 1, 1) <> Empty Then
For j = 23 To 45
d = 0
For r = fR To i
If arr(r, 49) <> Empty Then
If Not (arr(r, 8) Like "c?n l?i") Then
If arr(r, 8) Like "th?ng ch?n" Then
d = arr(r, j)
ElseIf IsNumeric(arr(r, j)) And arr(r, j) <> Empty Then
d = d + 1
End If
End If
End If
Next r
If d > 0 Then
k = k + 1
res(k, 1) = po
res(k, 2) = st
res(k, 3) = co
res(k, 4) = arr(1, j)
res(k, 5) = d
End If
Next j
End If
Next i
With Sheets("ketqua")
i = .Range("B" & Rows.Count).End(xlUp).Row
If i > 2 Then .Range("B3:F" & i).ClearContents
If k Then
.Range("B3").Resize(k).NumberFormat = "@"
.Range("B3").Resize(k, 5) = res
End If
End With
End Sub
