Option Explicit
Sub xyz()
Dim arr(), res(), a, C, b, bT
Dim sRow&, i&, r&, k&, j&, Col$
bT = Array(0, 9999, 9999, -9999, 9999, -9999, 9999)
C = Array(0, 1, 2, 3, 4, 6, 7, 8, 9, 11, 12)
With Sheets("Sheet DuLieu 1")
i = .Range("A1000000").End(xlUp).Row
If i < 4 Then Exit Sub
arr = .Range("A4:L" & i + 3).Value
sRow = UBound(arr) - 3
End With
ReDim res(1 To sRow, 1 To 10)
For i = 1 To sRow Step 3
If Col <> arr(i, 2) Then
ReDim a(1 To 6)
b = bT
Col = arr(i, 2)
End If
If Col = arr(i, 2) Then
If b(1) > arr(i, 7) Then
a(1) = i: b(1) = arr(i, 7)
End If
If b(2) > arr(i, 11) Then
a(2) = i: b(2) = arr(i, 11)
End If
If b(3) < arr(i, 12) Then
a(3) = i: b(3) = arr(i, 12)
End If
If b(4) > arr(i + 2, 7) Then
a(4) = i + 2: b(4) = arr(i + 2, 7)
End If
If b(5) < arr(i + 2, 11) Then
a(5) = i + 2: b(5) = arr(i + 2, 11)
End If
If b(6) > arr(i + 2, 12) Then
a(6) = i + 2: b(6) = arr(i + 2, 12)
End If
If Col <> arr(i + 3, 2) Then
For r = 1 To 6
For j = 1 To 10
res(k + r, j) = arr(a(r), C(j))
Next j
Next r
k = k + 6
End If
End If
Next i
With Sheets("Sheet Ketqua 1")
i = .Range("A1000000").End(xlUp).Row
If i > 3 Then .Range("A4:K" & i).Clear
.Range("A4").Resize(k, 10) = res
.Range("A4").Resize(k, 10).Borders.LineStyle = 1
End With
End Sub
Sub xyz2()
Dim arr(), res(), a, C, b, bT, VT
Dim sRow&, i&, r&, k&, j&, Beam$
bT = Array(0, 9999, -9999, -9999, -9999, -9999)
C = Array(0, 1, 2, 3, 4, 6, 7, 9, 13)
VT = Array("", "GT", "NH", "NH", "NH", "GP")
With Sheets("Sheet DuLieu 2")
i = .Range("A1000000").End(xlUp).Row
If i < 4 Then Exit Sub
arr = .Range("A4:M" & i + 1).Value
sRow = UBound(arr) - 1
End With
ReDim res(1 To sRow, 1 To 9)
For i = 1 To sRow
If Beam <> arr(i, 2) Then
ReDim a(1 To 5)
b = bT
Beam = arr(i, 2)
End If
If Beam = arr(i, 2) Then
If arr(i, 6) = "Min" Then
If b(1) > arr(i, 7) Then
a(1) = i: b(1) = arr(i, 7)
End If
If b(5) < arr(i, 7) Then
a(5) = i: b(5) = arr(i, 7)
End If
Else
For j = 2 To 4
If b(j) < arr(i, 13) Then
For r = 4 To j + 1 Step -1
a(r) = a(r - 1): b(r) = b(r - 1)
Next r
a(j) = i: b(j) = arr(i, 13)
Exit For
End If
Next j
End If
If Beam <> arr(i + 1, 2) Then
For r = 1 To 5
For j = 1 To 8
res(k + r, j) = arr(a(r), C(j))
Next j
res(k + r, 9) = VT(r)
Next r
k = k + 5
End If
End If
Next i
With Sheets("Sheet Ketqua 2")
i = .Range("A1000000").End(xlUp).Row
If i > 3 Then .Range("A4:I" & i).Clear
.Range("A4").Resize(k, 9) = res
.Range("A4").Resize(k, 9).Borders.LineStyle = 1
End With
End Sub
