|
|
Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
r = .Cells(Rows.Count, 2).End(xlUp).Row
If r < 2 Then MsgBox "数据表为空！": End
ar = .Range("a1:h" & r)
End With
ReDim br(1 To UBound(ar), 1 To 7)
br(1, 1) = "部门"
k = 1: y = 1
For i = 2 To UBound(ar)
If ar(i, 1) <> "" And ar(i, 3) <> "" Then
t = d(ar(i, 1))
If t = "" Then
k = k + 1
d(ar(i, 1)) = k
t = k
br(k, 1) = ar(i, 1)
End If
lh = d(ar(i, 3))
If lh = "" Then
y = y + 1
d(ar(i, 3)) = y
lh = y
br(1, y) = ar(i, 3)
End If
br(t, lh) = br(t, lh) + ar(i, 8)
End If
Next i
k = k + 1
br(k, 1) = "总计"
y = y + 1
br(1, y) = "总计"
For i = 2 To k
br(i, y) = Application.Sum(Application.Index(br, i, 0))
Next i
For j = 2 To y
br(k, j) = Application.Sum(Application.Index(br, 0, j))
Next j
With Sheets("分类汇总")
.[a1].CurrentRegion.Borders.LineStyle = 0
.[a1].CurrentRegion = Empty
.[a1].Resize(k, y) = br
.[a1].Resize(k, y).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-11-3 00:24
楼主
