|
Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Dim br(), cr()
With ActiveSheet
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 3 Then MsgBox "数据源为空!": End
ar = .Range("a2:f" & r)
ReDim br(1 To UBound(ar), 1 To 7)
ReDim cr(1 To UBound(ar), 1 To 4)
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
zd = ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4)
If Not d.exists(zd) Then Set d(zd) = CreateObject("scripting.dictionary")
d(zd)(ar(i, 6)) = d(zd)(ar(i, 6)) + 1
zf = ar(i, 2) & "|" & ar(i, 3)
If Not dc.exists(zf) Then Set dc(zf) = CreateObject("scripting.dictionary")
dc(zf)(ar(i, 4)) = dc(zf)(ar(i, 4)) + ar(i, 6)
End If
Next i
For Each k In d.keys
dic.RemoveAll
n = n + 1
For i = 2 To UBound(ar)
zd = ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4)
If zd = k Then
For j = 2 To 4
br(n, j - 1) = ar(i, j)
Next j
br(n, 4) = br(n, 4) + ar(i, 6)
br(n, 5) = br(n, 5) + Val(ar(i, 4)) * ar(i, 6)
sl = d(k)(ar(i, 6))
w = ar(i, 6) & "*" & sl
If Not dic.exists(w) Then
If br(n, 6) = "" Then
br(n, 6) = w
Else
br(n, 6) = br(n, 6) & "+" & w
End If
br(n, 7) = "(" & br(n, 6) & "*)" & ar(i, 4)
dic(w) = ""
End If
End If
Next i
Next k
.[i1].CurrentRegion.Offset(2) = Empty
.[i3].Resize(n, UBound(br, 2)) = br
For Each k In dc.keys
dic.RemoveAll
m = m + 1
For i = 2 To UBound(ar)
zd = ar(i, 2) & "|" & ar(i, 3)
If zd = k Then
For j = 2 To 3
cr(m, j - 1) = ar(i, j)
Next j
cr(m, 3) = cr(m, 3) + Val(ar(i, 4)) * ar(i, 6)
sl = dc(k)(ar(i, 4))
w = ar(i, 4) & "-" & sl & "根"
If Not dic.exists(w) Then
If cr(m, 4) = "" Then
cr(m, 4) = w
Else
cr(m, 4) = cr(m, 4) & "," & w
End If
dic(w) = ""
End If
End If
Next i
Next k
.[q1].CurrentRegion.Offset(2) = Empty
.[q3].Resize(m, UBound(cr, 2)) = cr
End With
Set d = Nothing
Set dc = Nothing
Set dic = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|