|
|
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ks = CDate(Format(DateSerial(Year(Date), Month(Date) - 1, 26), "yyyy-m-d"))
js = CDate(Format(DateSerial(Year(Date), Month(Date), 25), "yyyy-m-d"))
With Sheets("原始")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "原始为空！": End
ar = .Range("a1:s" & r)
End With
ReDim arr(1 To UBound(ar), 1 To 16)
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
If IsDate(ar(i, 1)) Then
If ar(i, 1) >= ks And ar(i, 1) <= js Then
n = n + 1
yf = Month(ar(i, 1))
d(yf) = ""
arr(n, 1) = ar(i, 1)
arr(n, 2) = ar(i, 2)
For j = 6 To 18
arr(n, j - 2) = ar(i, j)
Next j
End If
End If
End If
Next i
rr = Array(4, 6, 7, 10, 11)
If n = "" Then MsgBox "没有" & ks & "~" & js & "区间内的数据！": End
With Sheets("预计效果")
.UsedRange.Offset(5).Borders.LineStyle = 0
.UsedRange.Offset(5) = Empty
For Each k In d.keys
m = 0
ReDim brr(1 To n, 1 To 16)
For i = 1 To n
yf = Month(arr(i, 1))
If yf = k Then
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next j
End If
Next i
rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(rs, 1).Resize(m, UBound(brr, 2)) = brr
.Cells(rs + m, 1) = k & "月合计"
For s = 0 To UBound(rr)
lh = rr(s)
.Cells(rs + m, lh) = Application.Sum(Application.Index(brr, 0, lh))
Next s
.Cells(rs, 1).Resize(m + 1, UBound(brr, 2)).Borders.LineStyle = 1
Next k
.[p3] = ks & "~" & js
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-11-21 22:20
楼主