Public Sub THVT()
Dim DL, VL, NC, MTC, Tam, r As Long, c As Long, v, n, m
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
DL = Sheet1.UsedRange
ReDim VL(1 To UBound(DL), 1 To 5), NC(1 To UBound(DL), 1 To 5), MTC(1 To UBound(DL), 1 To 5)
With CreateObject("System.Collections.ArrayList")
For r = 4 To UBound(DL)
If IsNull(DL(r, 4)) = False Then
If Dic.exists(DL(r, 4)) = False Then
Dic.Add DL(r, 4), Array(DL(r, 5), DL(r, 6), DL(r, 10))
.Add DL(r, 4)
Else
Tam = Dic.Item(DL(r, 4))
Tam(2) = Tam(2) + DL(r, 10)
Dic.Item(DL(r, 4)) = Tam
End If
End If
Next r
.Sort
Tam = .ToArray
End With
For c = 0 To UBound(Tam)
If Left(Tam(c), 1) = "V" Then
v = v + 1: VL(v, 1) = v
VL(v, 2) = Tam(c): VL(v, 3) = Dic.Item(Tam(c))(0)
VL(v, 4) = Dic.Item(Tam(c))(1): VL(v, 5) = Dic.Item(Tam(c))(2)
End If
If Left(Tam(c), 1) = "N" Then
n = n + 1: NC(n, 1) = n
NC(n, 2) = Tam(c): NC(n, 3) = Dic.Item(Tam(c))(0)
NC(n, 4) = Dic.Item(Tam(c))(1): NC(n, 5) = Dic.Item(Tam(c))(2)
End If
If Left(Tam(c), 1) = "M" Then
m = m + 1: MTC(m, 1) = m
MTC(m, 2) = Tam(c): MTC(m, 3) = Dic.Item(Tam(c))(0)
MTC(m, 4) = Dic.Item(Tam(c))(1): MTC(m, 5) = Dic.Item(Tam(c))(2)
End If
Next c
With Sheet3
.UsedRange.Clear
.Range("A1").Resize(v, 5) = VL
.Range("A65000").End(xlUp).Offset(3).Resize(n, 5) = NC
.Range("A65000").End(xlUp).Offset(3).Resize(m, 5) = MTC
.UsedRange.Columns.AutoFit
.UsedRange.Borders.LineStyle = 1
.Range("E1", .Range("E65000").End(xlUp)).Style = "comma"
End With
Set Dic = Nothing
End Sub
