|
|
Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant, rn As Range
Dim br()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "成本表为空！": End
ar = .Range("a1:f" & r)
Set rn = .Range("b1:f1")
End With
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
s = ar(i, 1)
If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
d(s)(i) = ""
End If
Next i
For Each k In d.keys
n = 0: dc.RemoveAll
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) - 1)
For Each kk In d(k).keys
zd = ar(kk, 2) & "|" & ar(kk, 3)
t = dc(zd)
If t = "" Then
n = n + 1
dc(zd) = n
t = n
For j = 2 To 3
br(n, j - 1) = ar(kk, j)
Next j
End If
For j = 4 To 6
br(t, j - 1) = br(t, j - 1) + ar(kk, j)
Next j
Next kk
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
With sht
.Name = k & "月累计"
rn.Copy .[a1]
.[a2].Resize(n, UBound(br, 2)) = br
.[a1].Resize(n + 1, UBound(br, 2)).Borders.LineStyle = 1
End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
楼主: 123654！
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-24 17:20
楼主
