|
ub 汇总()
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 Sheets("合计")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r > 2 Then .Range("a3:aa" & r) = Empty: .Range("a3:aa" & r).Borders.LineStyle = 0
ar = .Range("a1:aa10000")
For j = 2 To UBound(ar, 2) Step 2
If Trim(ar(1, j)) <> "" Then
d(Trim(ar(1, j))) = j
End If
Next j
k = 2
For Each sh In Sheets
If sh.Name <> "合计" Then
rs = sh.Cells(Rows.Count, 8).End(xlUp).Row
br = sh.Range("a3:h" & rs)
lh = d(Trim(sh.Name))
For i = 2 To UBound(br)
If Trim(br(i, 8)) <> "" Then
t = d(Trim(br(i, 8)))
If t = "" Then
k = k + 1
d(Trim(br(i, 8))) = k
t = k
ar(k, 1) = br(i, 8)
End If
If lh <> "" Then
ar(t, lh) = ar(t, lh) + br(i, 2)
ar(t, lh + 1) = ar(t, lh + 1) + br(i, 3)
ar(t, 26) = ar(t, 26) + ar(t, lh)
ar(t, 27) = ar(t, 27) + ar(t, lh + 1)
End If
End If
Next i
End If
Next sh
.[a1].Resize(k, UBound(ar, 2)) = ar
.[a1].Resize(k, UBound(ar, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub |
|