|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ReDim arr(1 To 50000, 1 To 4)
For Each sh In Sheets
If sh.Index > 1 Then
r = sh.Cells(Rows.Count, 1).End(xlUp).Row
ar = sh.Range("a2:i" & r)
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
If InStr(ar(i, 2), "月") > 0 Then
zd = Trim(ar(i, 1)) & "|" & Trim(ar(i, 2))
t = d(zd)
If t = "" Then
k = k + 1
d(zd) = k
t = k
arr(k, 1) = ar(i, 1)
arr(k, 2) = ar(i, 2)
End If
arr(t, 3) = arr(t, 3) + ar(i, 3)
arr(t, 4) = arr(t, 4) + ar(i, 6)
End If
End If
Next i
End If
Next sh
'''汇总数据
For i = 1 To k
For s = i + 1 To k
If Val(arr(i, 2)) > Val(arr(s, 2)) Then
For j = 1 To 4
kk = arr(i, j)
arr(i, j) = arr(s, j)
arr(s, j) = kk
Next j
End If
Next s
Next i
'''按月份排序
With Sheets("汇总")
.[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
.[a1].CurrentRegion.Offset(2) = Empty
.[a3].Resize(k, 4) = arr
.[a3].Resize(k, 4).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub
|
|