Option Explicit
Sub xyz()
Dim arr(), res(), hcD As Boolean
Dim sRow&, i&, k&, phai$, giai$, tp$, tg$, tv3$
arr = Sheets("SD").Range("A5:E" & Sheets("SD").Range("B1000000").End(xlUp).Row).Value
sRow = UBound(arr)
ReDim res(1 To sRow, 1 To 3)
For i = 1 To sRow 'Vong 1
If arr(i, 1) Like "## Kg *" Then
If arr(i, 1) Like "*Nam*" Then phai = "Nam" Else phai = "Nu"
giai = arr(i, 1)
hcD = False
If tp <> phai Then
res(k + 1, 1) = "Vòng 1 " & phai
tp = phai
End If
End If
If arr(i, 2) Like "*Tranh Huy Ch??ng ??ng*" Then hcD = True
If hcD = False Then
If arr(i, 2) <> Empty And IsNumeric(arr(i, 2)) Then
If tg <> giai Then
k = k + 1
res(k, 2) = arr(i, 2)
res(k, 3) = giai
tg = giai
Else
res(k, 2) = res(k, 2) & ";" & arr(i, 2)
End If
End If
End If
Next i
For i = 1 To sRow 'Vong 2
If arr(i, 1) Like "## Kg *" Then
If arr(i, 1) Like "*Nam*" Then phai = "Nam" Else phai = "Nu"
giai = arr(i, 1)
hcD = False
If tp <> phai Then
res(k + 1, 1) = "Vòng 2 " & phai
tp = phai
End If
End If
If arr(i, 2) Like "*Tranh Huy Ch??ng ??ng*" Then hcD = True
If hcD = False Then
If arr(i, 3) <> Empty And IsNumeric(arr(i, 3)) Then '*** 3
If tg <> giai Then
k = k + 1
res(k, 2) = arr(i, 3) '*** 3
res(k, 3) = giai
tg = giai
Else
res(k, 2) = res(k, 2) & ";" & arr(i, 3) '*** 3
End If
End If
End If
Next i
For i = 1 To sRow 'Vong 3
If arr(i, 1) Like "## Kg *" Then
If arr(i, 1) Like "*Nam*" Then phai = "Nam" Else phai = "Nu"
giai = arr(i, 1)
hcD = False
If tp <> phai Then
res(k + 1, 1) = "Vòng 3 " & phai
tp = phai
End If
End If
If arr(i, 2) Like "*Tranh Huy Ch??ng ??ng*" Then hcD = True
If hcD = False Then
If arr(i, 4) <> Empty And IsNumeric(arr(i, 4)) Then '*** 4
If tg <> giai Then
k = k + 1
res(k, 2) = arr(i, 4) '*** 4
res(k, 3) = giai
tg = giai
Else
res(k, 2) = res(k, 2) & ";" & arr(i, 4) '*** 4
If tv3 <> Empty Then
res(k, 2) = res(k, 2) & ";" & tv3
tv3 = Empty
End If
End If
End If
If arr(i, 5) <> Empty And IsNumeric(arr(i, 5)) Then tv3 = arr(i, 5)
Else
If arr(i, 2) <> Empty And IsNumeric(arr(i, 2)) Then
res(k, 2) = arr(i, 2) & ";" & res(k, 2)
End If
End If
Next i
Sheets("SD").Range("O5").Resize(sRow, 3) = res
End Sub