Sub ABC()
Dim sArr(), Res(), Ma$
Dim eR&, i&, k&, iD&, N&, sRow&, TongSo#
With Sheets("Sheet1")
eR = .Range("I" & Rows.Count).End(xlUp).Row 'Dong cuoi
If eR > 1 Then .Range("I2:N" & eR).Clear 'Xoa ket qua cu
eR = .Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi
If eR < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
Res = .Range("A2:C" & eR).Value 'Du lieu goc
.Range("A2:C" & eR).Sort .[B2], 1, .[A2], , 1, Header:=xlNo ' Sort du lieu
sArr = .Range("A2:C" & eR + 1).Value 'Mang du lieu da Sort
.Range("A2:C" & eR).Value = Res 'Tra lai du lieu goc
.Range("D1").Formula = "=SUMPRODUCT(1/COUNTIF(B2:B" & eR & ",B2:B" & eR & "))" 'So ma hang
N = .Range("D1").Value * 4 'So dong ket qua
.Range("D1").ClearContents 'Xoa o tam
End With
ReDim Res(1 To N, 1 To 6)
sRow = UBound(sArr)
For i = 1 To sRow - 1
If Ma <> sArr(i, 2) Then 'Lan dau
iD = i
Ma = sArr(i, 2)
TongSo = 0
k = k + 1
Call GanKetQua(sArr, Res, k, TongSo, i, 3)
End If
If Ma <> sArr(i + 1, 2) Then
If i > iD + 1 Then 'Lan ke cuoi
k = k + 1
Call GanKetQua(sArr, Res, k, TongSo, i - 1, 4)
End If
If i > iD Then 'Lan gan nhat
k = k + 1
Call GanKetQua(sArr, Res, k, TongSo, i, 5)
End If
k = k + 1 'Dong tong
Res(k, 1) = sArr(i, 2)
Res(k, 6) = TongSo
End If
Next i
With Sheets("Sheet1")
.Range("I2").Resize(k, 6) = Res
.Range("I2").Resize(k, 6).Borders.LineStyle = 1
End With
End Sub
Private Sub GanKetQua(sArr, Res, k, TongSo, ByVal iR&, ByVal jC&)
Res(k, 1) = sArr(iR, 2)
Res(k, 2) = sArr(iR, 1)
Res(k, jC) = sArr(iR, 3)
Res(k, 6) = sArr(iR, 3)
TongSo = TongSo + sArr(iR, 3)
End Sub
