自动生成本月合计和累计

hellenlxy

自动生成本月合计和累计

linyh1742595842

这个比较麻烦，其实你应该分开求助，自己再组装起来
1 先按你的要求提取数据
2 再按你的要求求和统计

chxw68

1. Public d As Object
   
2. Public d1 As Object
   
3. Sub test()
   
4.   Dim r%, i%
   
5.   Dim arr, brr
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   Dim d2 As New Dictionary
   
9.   With Worksheets("期初余额")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a1:c" & r)
    
12.     For i = 1 To UBound(arr)
    
13.       d1(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))
    
14.     Next
    
15.   End With
    
16.   With Worksheets("凭证明细表")
    
17.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.     arr = .Range("a2:j" & r)
    
19.     For i = 1 To UBound(arr)
    
20.       If Not d.Exists(arr(i, 1)) Then
    
21.         m = 1
    
22.         ReDim brr(1 To 8, 1 To m)
    
23.       Else
    
24.         brr = d(arr(i, 1))
    
25.         m = UBound(brr, 2) + 1
    
26.         ReDim Preserve brr(1 To 8, 1 To m)
    
27.       End If
    
28.       For j = 5 To 10
    
29.         brr(j - 4, m) = arr(i, j)
    
30.       Next
    
31.       d(arr(i, 1)) = brr
    
32.     Next
    
33.   End With
    
34.   For Each aa In d.Keys
    
35.     arr = d(aa)
    
36.     ReDim brr(0 To UBound(arr, 2), 1 To UBound(arr))
    
37.     If d1.Exists(aa) Then
    
38.       brr(0, 8) = d1(aa)(1)
    
39.     End If
    
40.     For i = 1 To UBound(arr)
    
41.       For j = 1 To UBound(arr, 2)
    
42.         brr(j, i) = arr(i, j)
    
43.       Next
    
44.     Next
    
45.     For i = 1 To UBound(brr)
    
46.       brr(i, 8) = brr(i - 1, 8) + brr(i, 5) - brr(i, 6)
    
47.       d2(brr(i, 1)) = ""
    
48.     Next
    
49.     ReDim crr(0 To UBound(brr) + d2.Count * 2, 1 To UBound(brr, 2))
    
50.     For i = 0 To 1
    
51.       For j = 1 To UBound(brr, 2)
    
52.         crr(i, j) = brr(i, j)
    
53.       Next
    
54.     Next
    
55.     m = 1
    
56.     y1 = brr(1, 5)
    
57.     y2 = brr(1, 6)
    
58.     n1 = brr(1, 5)
    
59.     n2 = brr(1, 6)
    
60.     For i = 2 To UBound(brr)
    
61.       If brr(i, 1) <> brr(i - 1, 1) Then
    
62.         m = m + 1
    
63.         crr(m, 4) = "本月合计"
    
64.         crr(m, 5) = y1
    
65.         crr(m, 6) = y2
    
66.         m = m + 1
    
67.         crr(m, 4) = "本年合计"
    
68.         crr(m, 5) = n1
    
69.         crr(m, 6) = n2
    
70.         y1 = 0
    
71.         y2 = 0
    
72.       End If
    
73.       m = m + 1
    
74.       For j = 1 To UBound(brr, 2)
    
75.         crr(m, j) = brr(i, j)
    
76.       Next
    
77.       y1 = y1 + brr(i, 5)
    
78.       y2 = y2 + brr(i, 6)
    
79.       n1 = n1 + brr(i, 5)
    
80.       n2 = n2 + brr(i, 6)
    
81.     Next
    
82.     m = m + 1
    
83.     crr(m, 4) = "本月合计"
    
84.     crr(m, 5) = y1
    
85.     crr(m, 6) = y2
    
86.     m = m + 1
    
87.     crr(m, 4) = "本年合计"
    
88.     crr(m, 5) = n1
    
89.     crr(m, 6) = n2
    
90.     y1 = 0
    
91.     y2 = 0
    
92.     d(aa) = crr
    
93.   Next
    
94. End Sub
    

复制代码

chxw68

详见附件。

zgjijinbao

chxw68 发表于 2015-4-24 17:15
详见附件。

老师，我的数据小数无法相加啊？

zgjijinbao

这个数据，谢谢各位老师了！！！！

zgjijinbao

老师都不在线吗？谢谢

zgjijinbao

chxw68 发表于 2015-4-24 17:15
详见附件。

麻烦老师帮改一下吧

renkangjizhen

不用字典可能更简单

blackttea1

学习啦 ，谢谢