Sub TaoBC()
Dim Tg
Tg = Timer
FirstCode
Dim endR&, i&, s&, k&, nR&, sodong&, SumRws&, j&, T&
Dim sMa$, sMaKh$, MyStr$
Dim sArr(), rArr, ArrKH, ArrKq
Dim Dic As Object, DicKH As Object
Set Dic = CreateObject("Scripting.Dictionary")
Set DicKH = CreateObject("Scripting.Dictionary")
With Sheets("Data")
On Error Resume Next
.ShowAllData
On Error GoTo 0
endR = .Cells(65000, 1).End(3).Row
sArr = .Range("A2:D" & endR).Value
End With
s = 0: T = 0: sodong = 0
ReDim rArr(1 To UBound(sArr), 1 To 4)
ReDim ArrKH(1 To UBound(sArr), 1 To 2)
For i = 1 To UBound(sArr)
sMa = sArr(i, 1) & sArr(i, 2)
If Not Dic.Exists(sMa) Then
s = s + 1
Dic.Add sMa, s
rArr(s, 1) = sArr(i, 1) 'KH
rArr(s, 2) = sArr(i, 2) 'SP
End If
nR = Dic.Item(sMa)
rArr(nR, 3) = rArr(nR, 3) + sArr(i, 3)
rArr(nR, 4) = rArr(nR, 4) + sArr(i, 4)
'Phan nay lay du lieu ArrKH de subtotal
sMaKh = sArr(i, 1)
If Not DicKH.Exists(sMaKh) Then
T = T + 1
DicKH.Add sMaKh, T
ArrKH(T, 1) = sArr(i, 1) 'KH
End If
iR = DicKH.Item(sMaKh)
'ArrKH(iR, 2) = ArrKH(iR, 2) + 1
sodong = sodong + 1
If InStr(ArrKH(iR, 2), vbBack & nR) = 0 Then
ArrKH(iR, 2) = ArrKH(iR, 2) & vbBack & nR
End If
Next i
ReDim ArrKq(1 To sodong + 1, 1 To 4)
nR = 0
'Tao them dong SubTotal
For i = 1 To T
MyStr = Right(ArrKH(i, 2), Len(ArrKH(i, 2)) - 1) 'Bo VBBack o dau
aSplit = Split(MyStr, vbBack)
For j = LBound(aSplit) To UBound(aSplit)
nR = nR + 1
For k = 2 To 4
ArrKq(nR, k) = rArr(aSplit(j), k)
Next k
Next j
nR = nR + 1
ArrKq(nR, 1) = ArrKH(i, 1)
ArrKq(nR, 2) = "Total"
SumRws = UBound(aSplit) + 1
For k = 3 To 4
ArrKq(nR, k) = "=Subtotal(9,R[-1]C:R[-" & SumRws & "]C)"
Next k
Next i
nR = nR + 1
ArrKq(nR, 2) = "Sub Total"
For k = 3 To 4
ArrKq(nR, k) = "=Subtotal(9,R[-1]C:R[-" & nR - 1 & "]C)"
Next k
With Sheets("TongHop")
.[A6].Resize(1000, 4).ClearContents
.[A6].Resize(sodong + 1, 4) = ArrKq
End With
Erase sArr(), rArr, ArrKH, ArrKq
EndCode
MsgBox Timer - Tg
End Sub
Sub EndCode()
With Application
.EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub
Sub FirstCode()
With Application
.EnableEvents = False: .DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
End Sub
