|
|
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long
Dim brr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("销售")
r = .Cells(Rows.Count, 3).End(xlUp).Row
ar = .Range("c2:g" & r)
End With
With Sheets("进货")
br = .Range("k3:u16")
End With
For i = 2 To UBound(br)
If br(i, 1) <> "" Then
If IsDate(br(i, 1)) Then
yf = Month(br(i, 1)) & "月"
d(yf) = br(i, 10)
End If
End If
Next i
ReDim brr(1 To 13, 1 To 500)
rr = Array("收入合计", "购油款", "人工费", "油机维修费", "车加油/维修", "杂费", "支出合计", "毛利")
brr(1, 1) = "日期"
k = 1: y = 1
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
If IsDate(ar(i, 1)) Then
yf = Month(ar(i, 1)) & "月"
t = dc(yf)
If t = "" Then
k = k + 1
dc(yf) = k
t = k
brr(k, 1) = yf
End If
If ar(i, 5) <> "" Then
lh = dc(ar(i, 5))
If lh = "" Then
y = y + 1
dc(ar(i, 5)) = y
lh = y
brr(1, y) = ar(i, 5)
End If
brr(t, lh) = brr(t, lh) + ar(i, 4)
End If
End If
End If
Next i
If k = 1 Then MsgBox "没有需要汇总的数据！": End
m = y
For j = 0 To UBound(rr)
y = y + 1
brr(1, y) = rr(j)
Next j
For i = 2 To k
For j = 2 To m
brr(i, m + 1) = brr(i, m + 1) + brr(i, j)
Next j
brr(i, m + 2) = d(brr(i, 1))
Next i
With Sheets("年报")
.[a1].CurrentRegion.Borders.LineStyle = 0
.[a1].CurrentRegion = Empty
.[a1].Resize(k, y) = brr
.[a1].Resize(k + 1, y).Borders.LineStyle = 1
.Cells(k + 1, 1) = "合计"
For i = 2 To k
.Cells(i, y - 1).FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
Next i
For j = 2 To y
.Cells(k + 1, j).FormulaR1C1 = "=SUM(R[-12]C:R[-1]C)"
Next j
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-1-3 15:57
楼主
