Sub ABC()
Dim aSh, sArr(), aSTT(), res(), Sh As Worksheet, stt&, tmp
Dim eRow&, sRow&, sCol&, eR&, i&, r&, j&, k&, q&, n&
'On Error Resume Next
Set Sh = Sheets("KET QUA")
Sh.Range("A2:L10000").Clear
eRow = Sh.Range("P" & Rows.Count).End(xlUp).Row
If eRow < 2 Then MsgBox ("Khong Co STT!"): Exit Sub
aSTT = Sh.Range("P2:Q" & eRow).Value 'Lay 2 cot P va Q
ReDim res(1 To 1000, 1 To 12) 'Gioi han ket qua 1000 dong
aSh = Array("DC", "KD", "MD") 'Cac sheet du lieu
Application.ScreenUpdating = false
For q = 1 To UBound(aSTT)
stt = aSTT(q, 1)
For n = 0 To UBound(aSh)
With Sheets(aSh(n))
If Err.Number = 0 Then 'Neu có sheet aSh(n)
sArr = .Range("A2:L" & .Range("B" & Rows.Count).End(xlUp).Row + 2).Value
sRow = UBound(sArr) - 1
sArr(sRow, 1) = "a": sCol = 0
For i = 1 To sRow
tmp = sArr(i, 1)
If tmp <> Empty Then
If tmp = stt Then
If n > 0 Then
If sArr(i + 1, 1) <> Empty Then Exit For
i = i + 1
sCol = 9
k = k + 1
Else
sCol = 12
End If
Else
If sCol > 0 Then Exit For
End If
End If
If sCol > 0 And sArr(i, 2) <> Empty Then
k = k + 1
For j = 1 To sCol
res(k, j) = sArr(i, j)
Next j
If InStr(1, res(k, 2), "ZONE", vbTextCompare) Then r = k
If res(k, 1) <> Empty Then k = k + 1
End If
Next i
If i < sRow + 1 Then 'Cong thuc SUM
If r Then res(r, 9) = "=Sum(I" & r + 2 & ":I" & k + 2 & ")"
End If
Else 'Khong có sheet aSh(n)
Err.Number = 0
End If
End With
Next n
Next q
If k Then
Sh.Range("A2").Resize(k, 12) = res
Sh.Range("A2").Resize(k, 12).Borders.Weight = xlThin
Sh.Range("A2").Resize(k, 12).Borders(xlInsideHorizontal).Weight = xlHairline
For i = 2 To k + 1
If Sh.Range("A" & i).Value <> Empty Or InStr(1, Sh.Range("B" & i).Value, "ZONE", vbTextCompare) Then
Sh.Range("A" & i).Resize(, 12).Font.Bold = True
End If
Next i
End If
Application.ScreenUpdating = True
End Sub
