|
Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
r = .Cells(Rows.Count, 2).End(xlUp).Row
If r < 4 Then MsgBox "数据源为空!": End
ar = .Range("a3:d" & r)
ReDim br(1 To UBound(ar), 1 To 2)
For i = 2 To UBound(ar)
If ar(i, 2) <> "" Then
t = d(ar(i, 2))
If t = "" Then
k = k + 1
d(ar(i, 2)) = k
t = k
br(k, 1) = ar(i, 2)
End If
br(t, 2) = br(t, 2) + ar(i, 3)
End If
Next i
rs = .Cells(Rows.Count, 6).End(xlUp).Row
If rs >= 4 Then .Range("f4:g" & rs) = Empty
.[f4].Resize(k, 2) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|