Sub LungTung()
Dim sArr(), sArr2(), atO(), atO2(), atG(), atG2(), Res(), Res2()
Dim eRow&, sRow&, eCol&, i&, j&, r&, c&, n&
Dim aTDdong(), aTDcot(), iText$
With Sheets("So lieu")
iText = Left(.Range("C5").Value, 7) & "dòng "
End With
With Sheets("Du lieu")
eRow = .Range("AC" & Rows.Count).End(xlUp).Row
sArr = .Range("AT6:BK" & eRow).Value
sArr2 = .Range("CY6:DP" & eRow).Value
atO = .Range("AG6:AG" & eRow).Value
atO2 = .Range("CG6:CG" & eRow).Value
atG = .Range("AC6:AC" & eRow).Value
atG2 = .Range("CV6:CV" & eRow).Value
End With
sRow = UBound(sArr)
ReDim aTDdong(1 To sRow * 4, 1 To 1)
ReDim Res(1 To sRow * 4, 1 To 3)
ReDim aTDcot(1 To 1, 1 To sRow * 4)
ReDim Res2(1 To 9, 1 To sRow * 4)
r = -3: c = -3
For i = 1 To sRow
'Ket qua 1
r = r + 4
aTDdong(r, 1) = iText & i
Res(r, 1) = sArr(i, 1) 'toa do O
Res(r, 2) = sArr(i, 2)
Res(r, 3) = atO(i, 1)
Res(r + 1, 1) = sArr(i, 17) 'toa do G
Res(r + 1, 2) = sArr(i, 18)
Res(r + 1, 3) = atG(i, 1)
Res(r + 2, 1) = sArr2(i, 1) 'toa do O'
Res(r + 2, 2) = sArr2(i, 2)
Res(r + 2, 3) = atO2(i, 1)
Res(r + 3, 1) = sArr2(i, 17) 'toa do G'
Res(r + 3, 2) = sArr2(i, 18)
Res(r + 3, 3) = atG2(i, 1)
'Ket qua 2
c = c + 4
aTDcot(1, c) = iText & i
For n = 1 To 9
Res2(n, c) = sArr(i, (n - 1) * 2 + 1)
Res2(n, c + 1) = sArr(i, n * 2)
Res2(n, c + 2) = sArr2(i, (n - 1) * 2 + 1)
Res2(n, c + 3) = sArr2(i, n * 2)
Next n
Next i
With Sheets("So lieu")
'Ket qua 1
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow > 10 Then .Range("A11:E" & eRow).Clear
eRow = UBound(Res) + 6
If eRow > 10 Then
.Range("A7:B10").Copy .Range("A11:E" & eRow)
End If
.Range("A7:A" & eRow) = aTDdong
.Range("C7:E" & eRow) = Res
.Range("C7:E" & eRow).Borders.LineStyle = 1
'Ket qua 2
eCol = .Cells(6, 10000).End(xlToLeft).Column
If eCol > 10 Then .Range("K5", .Cells(15, eCol)).Clear
eCol = UBound(Res2, 2) + 6
If eCol > 10 Then
.Range("G5:J6").Copy .Range("K5", .Cells(6, eCol))
End If
.Range("G5", .Cells(5, eCol)) = aTDcot
.Range("G7", .Cells(15, eCol)) = Res2
.Range("G5", .Cells(15, eCol)).Borders.LineStyle = 1
End With
End Sub
