Option Explicit
Sub TH_Arr()
Dim Arr(), Rng As Range
Dim Rws As Long, J&, W&, TgN#, TgX#
Dim Tmp$, SF$, Tong$
Set Rng = [B2].CurrentRegion: Rws = Rng.Rows.Count
Rng.Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Range("B3") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
Arr() = [A3].Resize(Rws, 4).Value
ReDim dArr(1 To 2 * Rws, 1 To 6): Tong = [k3].Value
For J = 1 To Rws
Tmp = Left(Arr(J, 2), 1): SF = Arr(J, 1)
If SF = "" Then Exit For
W = W + 1
dArr(W, 1) = Arr(J, 1): dArr(W, 2) = Arr(J, 2)
If Tmp = "N" Then
dArr(W, 3) = Arr(J, 3): dArr(W, 4) = Arr(J, 4)
TgN = TgN + Arr(J, 4)
ElseIf Tmp = "X" Then
dArr(W, 5) = Arr(J, 3): dArr(W, 6) = Arr(J, 4)
TgX = TgX + Arr(J, 4)
End If
If SF <> Arr(J + 1, 1) Then
W = W + 1: dArr(W, 2) = Tong
dArr(W, 4) = TgN: TgN = 0
dArr(W, 6) = TgX: TgX = 0
End If
Next J
[j5].Resize(W, 6).Value = dArr()
End SubNếu như bắt buộc chắc em sẽ phải thêm phần số TT như bác nói, vì em đã tạo vùng trên sheet để nhập dữ liệu, nên việc thay đổi để đánh số TT tự động chắc sẽ cần thêm chút thời gian.
Nếu không được em sẽ gửi dữ liệu lên.
Nếu dùng công thức thì khi em xóa vùng dữ liệu thì còn tính được không ạ. Vùng từ C2:G15 là vùng em vừa dùng advanced filter để lọc ra từ dữ liệu nguồn. (vùng này là vùng tạm, bởi sau khi dùng xong thì em xóa luôn).
sao không báo cáo kiểu này nhỉ .
Public Sub GPE()
Application.ScreenUpdating = False
Dim sArr(), dArr(), tArr(), I As Long, Tem As String, Num1 As Long, Num2 As Long, K As Long
'--------------------------------------------------
tArr = Range([A3], [A3].End(xlDown)).Resize(, 4).Value
[P4:S4].Resize(UBound(tArr, 1)) = tArr
[P4:S4].Resize(UBound(tArr, 1)).Sort Key1:=[P4], Key2:=[Q4]
'--------------------------------------------------
sArr = Range("P4:S4").Resize(UBound(tArr, 1) + 1).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
Tem = sArr(1, 1)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) <> Tem Then
K = IIf(Num1 > Num2, Num1, Num2)
Num1 = K: Num2 = K
Tem = sArr(I, 1)
End If
If Left(sArr(I, 2), 1) = "N" Then
Num1 = Num1 + 1
dArr(Num1, 1) = sArr(I, 1)
dArr(Num1, 2) = sArr(I, 3)
dArr(Num1, 3) = sArr(I, 4)
Else
Num2 = Num2 + 1
dArr(Num2, 1) = sArr(I, 1)
dArr(Num2, 4) = sArr(I, 3)
dArr(Num2, 5) = sArr(I, 4)
End If
Next I
[J5].Resize(K, 5) = dArr
[P4:S1000].Clear
End SubCảm ơn bác, pivot thì rất ok ạ, nhưng của em dữ liệu nhiều, để ra nhiều dòng khó in ấn và nhất là xếp thích phải bố cục như thế nên em phải tìm cách viết khác.
Em chưa được học vụ Num1, Num2 này, cảm ơn bác, quá tuyệt.
