|
Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
.UsedRange.Offset(5) = Empty
m = Sheets.Count + 10
ar = .Range("b3:q" & m)
For j = 2 To UBound(ar, 2) - 2 Step 3
If ar(2, j) <> "" Then
d(ar(2, j)) = j
End If
Next j
k = 5
For Each sh In Sheets
If sh.Index > 1 Then
r = sh.Cells(Rows.Count, 2).End(xlUp).Row
k = k + 1
br = sh.Range("b4:k" & r)
ar(k, 1) = sh.Name
For i = 2 To UBound(br)
If br(i, 3) <> "" Then
lh = d(br(i, 3))
If lh <> "" Then
ar(k, lh) = ar(k, lh) + br(i, 5)
ar(k, lh + 1) = ar(k, lh) + br(i, 8)
ar(k, lh + 2) = ar(k, lh) + br(i, 9)
End If
End If
Next i
End If
Next sh
.[b3].Resize(k, UBound(ar, 2)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|