Public Function TangTocCode(TangToc As Boolean)
With Application
.ScreenUpdating = Not (TangToc)
.EnableEvents = Not (TangToc)
.Calculation = IIf(TangToc, xlCalculationManual, xlCalculationAutomatic)
End With
End Function
Sub SumKhongSort()
On Error GoTo End_
Call TangTocCode(True)
Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
Dim iKey, S, ik&, iSub&, sRow&, r As Long, k As Long, eA As Long, c As Long, a As Long
Dim rng As Range, RngU As Range, rTam As Range, txtRng As String, txt As String
Dim aTam() As Variant, nhom As Long, TongCong As Long, t As Single
t = Timer
Const ofset As Integer = 8
Set rng = Sheet1.Range("A1")
rng.CurrentRegion.Sort Key1:=rng, Order1:=xlAscending, Header:=xlYes
aChuaSum = rng.CurrentRegion.Value
eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2)
If eA < 2 Then Exit Sub
Set Dic = CreateObject("scripting.dictionary")
For r = 2 To eA
sMa = aChuaSum(r, 1)
If Not Dic.Exists(sMa) Then k = k + 1
Dic.Item(sMa) = Dic.Item(sMa) & "," & r
Next r
sRow = eA + k - 1: k = 0
ReDim aSumSum(1 To sRow, 1 To a)
For Each iKey In Dic.Keys
S = Split(Dic.Item(iKey), ",")
iSub = k + UBound(S) + 1
aSumSum(iSub, 1) = "Tong cong: "
TongCong = TongCong + 1
txtRng = "I" & iSub + 1 & ":N" & iSub + 1
If txt = Empty Then
txt = txtRng
Else
If Len(txt) < 100 Then
txt = txt & "," & txtRng
Else
txt = txt & "," & txtRng
nhom = nhom + 1
ReDim Preserve aTam(1 To 1, 1 To nhom)
aTam(1, nhom) = txt: txt = Empty
End If
End If
For r = 1 To UBound(S)
k = k + 1
ik = CLng(S(r))
aSumSum(k, 1) = aChuaSum(ik, 1)
For c = 2 To a
aSumSum(k, c) = aChuaSum(ik, c)
aSumSum(iSub, c) = aSumSum(iSub, c) + aChuaSum(ik, c)
Next c
Next r
k = k + 1
Next iKey
With rng.Offset(1, ofset)
.CurrentRegion.Clear
.Resize(sRow, a) = aSumSum
End With
rng.Offset(, ofset).Resize(, a).Value = rng.Resize(, a).Value
For r = 1 To nhom
txt = aTam(1, r)
Sheet1.Range(txt).Font.Bold = True
Next r
End_:
Call TangTocCode(False)
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, Err.Number
Else
txt = vbNewLine & "So dong tong cong la: " & TongCong & vbNewLine & _
"So vung duoc to dam la: " & nhom & vbNewLine & _
"Thoi gian xy ly la: " & Timer - t
MsgBox "Xong roi," & txt, vbInformation + vbOKOnly
End If
End Sub
