根据流水账生成汇总和明细

李桥贵

求助：根据流水账用Vba生成一年12个月的各种费用收入和支出汇总表，一年12个月各类费用明细表和报销凭证
账务.zip (231.29 KB, 下载次数: 350)

2015-5-12 15:54 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d(1 To 2) As Object
   
5.   Set d(1) = CreateObject("scripting.dictionary")
   
6.   Set d(2) = CreateObject("scripting.dictionary")
   
7.   With Worksheets("流水帐")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a5:j" & r)
   
10.     For i = 1 To UBound(arr)
    
11.       yf = Month(arr(i, 1))
    
12.       For j = 1 To 2
    
13.         If Len(arr(i, j + 8)) <> 0 Then
    
14.           If Not d(j).exists(arr(i, 8)) Then
    
15.             ReDim brr(1 To 14)
    
16.             brr(1) = arr(i, 8)
    
17.           Else
    
18.             brr = d(j)(arr(i, 8))
    
19.           End If
    
20.           brr(yf + 1) = brr(yf + 1) + arr(i, j + 8)
    
21.           brr(14) = brr(14) + arr(i, j + 8)
    
22.           d(j)(arr(i, 8)) = brr
    
23.         End If
    
24.       Next
    
25.     Next
    
26.   End With
    
27.   k = 0
    
28.   For Each ws In Worksheets(Array("支出汇总", "收入汇总"))
    
29.     k = k + 1
    
30.     With ws
    
31.       .UsedRange.Offset(1, 0).Clear
    
32.       .Range("a2").Resize(d(k).Count, 14) = Application.Transpose(Application.Transpose(d(k).items))
    
33.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
34.       .Range("a1:n" & r).Borders.LineStyle = xlContinuous
    
35.     End With
    
36.   Next
    
37. End Sub
    

复制代码

chxw68

详见附件。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim km(1 To 2) As String
   
5.   Dim d(1 To 2) As Object
   
6.   Dim d1(1 To 2) As Object
   
7.   Set d(1) = CreateObject("scripting.dictionary")
   
8.   Set d(2) = CreateObject("scripting.dictionary")
   
9.   Set d1(1) = CreateObject("scripting.dictionary")
   
10.   Set d1(2) = CreateObject("scripting.dictionary")
    
11.   km(1) = "支出"
    
12.   km(2) = "收入"
    
13.   With Worksheets("流水帐")
    
14.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.     arr = .Range("a5:j" & r)
    
16.     For i = 1 To UBound(arr)
    
17.       yf = Month(arr(i, 1))
    
18.       For j = 1 To 2
    
19.         If Len(arr(i, j + 8)) <> 0 Then
    
20.           If Not d(j).exists(arr(i, 8)) Then
    
21.             ReDim brr(1 To 14)
    
22.             brr(1) = arr(i, 8)
    
23.           Else
    
24.             brr = d(j)(arr(i, 8))
    
25.           End If
    
26.           brr(yf + 1) = brr(yf + 1) + arr(i, j + 8)
    
27.           brr(14) = brr(14) + arr(i, j + 8)
    
28.           d(j)(arr(i, 8)) = brr
    
29.          
    
30.           If Not d1(j).exists(yf) Then
    
31.             Set d1(j)(yf) = CreateObject("scripting.dictionary")
    
32.           End If
    
33.           If Not d1(j)(yf).exists(arr(i, 8)) Then
    
34.             m = 1
    
35.             ReDim crr(1 To 4, 1 To m)
    
36.           Else
    
37.             crr = d1(j)(yf)(arr(i, 8))
    
38.             m = UBound(crr, 2) + 1
    
39.             ReDim Preserve crr(1 To 4, 1 To m)
    
40.           End If
    
41.           crr(1, m) = arr(i, 1)
    
42.           crr(2, m) = arr(i, 7)
    
43.           crr(3, m) = arr(i, j + 8)
    
44.           d1(j)(yf)(arr(i, 8)) = crr
    
45.            
    
46.         End If
    
47.       Next
    
48.     Next
    
49.   End With
    
50.   For k = 1 To 2
    
51.     With Worksheets(km(k) & "汇总")
    
52.       .UsedRange.Offset(1, 0).Clear
    
53.       .Range("a2").Resize(d(k).Count, 14) = Application.Transpose(Application.Transpose(d(k).items))
    
54.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
55.       .Range("a1:n" & r).Borders.LineStyle = xlContinuous
    
56.     End With
    
57.     With Worksheets(km(k) & "各种费用明细")
    
58.       .Cells.Clear
    
59.       n = 1
    
60.       For Each aa In d1(k).keys
    
61.         ss = 0
    
62.         With .Cells(1, n)
    
63.           .Value = aa & "月份"
    
64.           .Font.Bold = True
    
65.           .Resize(1, 5).Merge
    
66.           .HorizontalAlignment = xlCenter
    
67.           .VerticalAlignment = xlCenter
    
68.         End With
    
69.         For Each bb In d1(k)(aa).keys
    
70.           brr = d1(k)(aa)(bb)
    
71.           ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
72.           For i = 1 To UBound(brr)
    
73.             For j = 1 To UBound(brr, 2)
    
74.               crr(j, i) = brr(i, j)
    
75.             Next
    
76.           Next
    
77.           r = .Cells(.Rows.Count, n + 1).End(xlUp).Row + 1
    
78.           With .Cells(r, n)
    
79.             .Value = bb
    
80.             .Resize(UBound(crr), 1).Merge
    
81.           End With
    
82.           .Cells(r, n + 1).Resize(UBound(crr), UBound(crr, 2)) = crr
    
83.           With .Cells(r, n + 4)
    
84.             .Resize(UBound(crr), 1).Merge
    
85.             .Value = Application.Sum(Application.Index(crr, 0, 3))
    
86.             ss = ss + .Value
    
87.           End With
    
88.         Next
    
89.         r = .Cells(.Rows.Count, n + 1).End(xlUp).Row + 1
    
90.         With .Cells(r, n)
    
91.           .Value = "合  计"
    
92.           .Font.Bold = True
    
93.           .HorizontalAlignment = xlCenter
    
94.           .VerticalAlignment = xlCenter
    
95.         End With
    
96.         .Cells(r, n + 3).Resize(1, 2) = ss
    
97.         .Cells(1, n).Resize(r, 5).Borders.LineStyle = xlContinuous
    
98.         n = n + 5
    
99.       Next
    
100.     End With
     
101.   Next
     
102. End Sub
     

复制代码

chxw68

增加了汇总收入和支出明细功能。

chxw68

按楼主样表修改了明细表格式。

李桥贵

chxw68 发表于 2015-5-12 17:57
按楼主样表修改了明细表格式。

再麻烦老师一下，帮忙做一下各个科目的报销凭证

chxw68

李桥贵 发表于 2015-5-13 10:37
再麻烦老师一下，帮忙做一下各个科目的报销凭证

各科目的报销凭证怎么做？一个科目生成一张工作表？

李桥贵

chxw68 发表于 2015-5-13 10:58
各科目的报销凭证怎么做？一个科目生成一张工作表？

谢谢教师在百忙之中抽出时间帮忙！
是的一个科目生成一张工作表。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim km(1 To 2) As String
   
5.   Dim ws As Worksheet
   
6.   Dim hg(1 To 26), lk(1 To 14)
   
7.   Dim d(1 To 2) As Object
   
8.   Dim d1(1 To 2) As Object
   
9.   Dim d2(1 To 2) As Object
   
10.   Dim d3(1 To 2) As Object
    
11.   Application.ScreenUpdating = False
    
12.   Application.DisplayAlerts = False
    
13.   Set d(1) = CreateObject("scripting.dictionary")
    
14.   Set d(2) = CreateObject("scripting.dictionary")
    
15.   Set d1(1) = CreateObject("scripting.dictionary")
    
16.   Set d1(2) = CreateObject("scripting.dictionary")
    
17.   Set d2(1) = CreateObject("scripting.dictionary")
    
18.   Set d2(2) = CreateObject("scripting.dictionary")
    
19.   Set d3(1) = CreateObject("scripting.dictionary")
    
20.   Set d3(2) = CreateObject("scripting.dictionary")
    
21.   Set dsh = CreateObject("scripting.dictionary")
    
22.   km(1) = "支出"
    
23.   km(2) = "收入"
    
24.   For Each ws In Worksheets
    
25.     dsh(ws.Name) = ""
    
26.   Next
    
27.   With Worksheets("模板")
    
28.     For i = 1 To 26
    
29.       hg(i) = .Rows(i).RowHeight
    
30.     Next
    
31.     For j = 1 To 14
    
32.       lk(j) = .Columns(j).ColumnWidth
    
33.     Next
    
34.   End With
    
35.    
    
36.   With Worksheets("流水帐")
    
37.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
38.     arr = .Range("a5:j" & r)
    
39.     For i = 1 To UBound(arr)
    
40.       yf = Month(arr(i, 1))
    
41.       For j = 1 To 2
    
42.         If Len(arr(i, j + 8)) <> 0 Then
    
43.           If Not d(j).exists(arr(i, 8)) Then
    
44.             ReDim brr(1 To 14)
    
45.             brr(1) = arr(i, 8)
    
46.           Else
    
47.             brr = d(j)(arr(i, 8))
    
48.           End If
    
49.           brr(yf + 1) = brr(yf + 1) + arr(i, j + 8)
    
50.           brr(14) = brr(14) + arr(i, j + 8)
    
51.           d(j)(arr(i, 8)) = brr
    
52.          
    
53.           If Not d1(j).exists(yf) Then
    
54.             Set d1(j)(yf) = CreateObject("scripting.dictionary")
    
55.           End If
    
56.           If Not d1(j)(yf).exists(arr(i, 8)) Then
    
57.             m = 1
    
58.             ReDim crr(1 To 4, 1 To m)
    
59.           Else
    
60.             crr = d1(j)(yf)(arr(i, 8))
    
61.             m = UBound(crr, 2) + 1
    
62.             ReDim Preserve crr(1 To 4, 1 To m)
    
63.           End If
    
64.           crr(1, m) = arr(i, 1)
    
65.           crr(2, m) = arr(i, 7)
    
66.           crr(3, m) = arr(i, j + 8)
    
67.           d1(j)(yf)(arr(i, 8)) = crr
    
68.          
    
69.           If Not d3(j).exists(arr(i, 8)) Then
    
70.             Set d3(j)(arr(i, 8)) = CreateObject("scripting.dictionary")
    
71.           End If
    
72.           If Not d3(j)(arr(i, 8)).exists(yf) Then
    
73.             m = 1
    
74.             ReDim frr(1 To 11, 1 To m)
    
75.           Else
    
76.             frr = d3(j)(arr(i, 8))(yf)
    
77.             m = UBound(frr, 2) + 1
    
78.             ReDim Preserve frr(1 To 11, 1 To m)
    
79.           End If
    
80.           frr(1, m) = m
    
81.           frr(2, m) = Month(arr(i, 1))
    
82.           frr(3, m) = Day(arr(i, 1))
    
83.           frr(4, m) = Month(arr(i, 2))
    
84.           frr(5, m) = Day(arr(i, 2))
    
85.           frr(6, m) = arr(i, 3)
    
86.           frr(7, m) = arr(i, 4)
    
87.           frr(8, m) = arr(i, 5)
    
88.           frr(9, m) = arr(i, 6)
    
89.           frr(10, m) = arr(i, 7)
    
90.           frr(11, m) = arr(i, j + 8)
    
91.           d3(j)(arr(i, 8))(yf) = frr
    
92.         End If
    
93.       Next
    
94.     Next
    
95.   End With
    
96.   For k = 1 To 2
    
97.     For Each aa In d1(k).keys
    
98.       For Each bb In d1(k)(aa).keys
    
99.         n = UBound(d1(k)(aa)(bb), 2)
    
100.         If Not d2(k).exists(bb) Then
     
101.           d2(k)(bb) = Array(0, n)
     
102.         Else
     
103.           crr = d2(k)(bb)
     
104.           If crr(1) < n Then
     
105.             crr(1) = n
     
106.           End If
     
107.           d2(k)(bb) = crr
     
108.         End If
     
109.       Next
     
110.     Next
     
111.   Next
     
112.   For k = 1 To 2
     
113.     kk = d2(k).keys
     
114.     For i = 0 To UBound(kk)
     
115.       crr = d2(k)(kk(i))
     
116.       If i = 0 Then
     
117.         crr(0) = 2
     
118.       Else
     
119.         crr(0) = d2(k)(kk(i - 1))(0) + d2(k)(kk(i - 1))(1)
     
120.       End If
     
121.       d2(k)(kk(i)) = crr
     
122.     Next
     
123.     crr(0) = d2(k)(kk(i - 1))(0) + d2(k)(kk(i - 1))(1)
     
124.     crr(1) = 1
     
125.     d2(k)("合  计") = crr
     
126.   Next
     
127.   tt = d2(1).items
     
128.   For k = 1 To 2
     
129.     With Worksheets(km(k) & "汇总")
     
130.       .UsedRange.Offset(1, 0).Clear
     
131.       .Range("a2").Resize(d(k).Count, 14) = Application.Transpose(Application.Transpose(d(k).items))
     
132.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
     
133.       .Range("a1:n" & r).Borders.LineStyle = xlContinuous
     
134.     End With
     
135.     With Worksheets(km(k) & "各种费用明细")
     
136.       .Cells.Clear
     
137.       For Each aa In d2(k).keys
     
138.         crr = d2(k)(aa)
     
139.         With .Cells(crr(0), 1)
     
140.           .Value = aa
     
141.           .Resize(crr(1), 1).Merge
     
142.         End With
     
143.       Next
     
144.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
     
145.       .Range("a1") = "科  目"
     
146.       With .Range("a1:a" & r)
     
147.         .Borders.LineStyle = xlContinuous
     
148.         .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
     
149.       End With
     
150.       With .Range("a" & r)
     
151.         .Font.Bold = True
     
152.         .HorizontalAlignment = xlCenter
     
153.         .VerticalAlignment = xlCenter
     
154.       End With
     
155.       n = 2
     
156.       For Each aa In d1(k).keys
     
157.         ss = 0
     
158.         With .Cells(1, n)
     
159.           .Value = aa & "月份"
     
160.           .Resize(1, 4).Merge
     
161.         End With
     
162.         For Each bb In d1(k)(aa).keys
     
163.           brr = d1(k)(aa)(bb)
     
164.           drr = d2(k)(bb)
     
165.           ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
     
166.           For i = 1 To UBound(brr)
     
167.             For j = 1 To UBound(brr, 2)
     
168.               crr(j, i) = brr(i, j)
     
169.             Next
     
170.           Next
     
171.           .Cells(drr(0), n).Resize(UBound(crr), UBound(crr, 2)) = crr
     
172.           With .Cells(drr(0), n + 3)
     
173.             .Resize(drr(1), 1).Merge
     
174.             .Value = Application.Sum(Application.Index(crr, 0, 3))
     
175.             ss = ss + .Value
     
176.           End With
     
177.         Next
     
178.         drr = d2(k)("合  计")
     
179.         .Cells(drr(0), n + 2).Resize(1, 2) = ss
     
180.         With .Cells(1, n).Resize(drr(0), 4)
     
181.           .Borders.LineStyle = xlContinuous
     
182.           .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
     
183.         End With
     
184.         n = n + 4
     
185.       Next
     
186.       With .Rows(1)
     
187.         .Font.Bold = True
     
188.         .HorizontalAlignment = xlCenter
     
189.         .VerticalAlignment = xlCenter
     
190.       End With
     
191.     End With
     
192.     For Each aa In d3(k).keys
     
193.       If Not dsh.exists(aa) Then
     
194.         Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
     
195.         With ws
     
196.           .Name = aa
     
197.         End With
     
198.       End If
     
199.       With Worksheets(aa)
     
200.         .Cells.Clear
     
201.       End With
     
202.       m = 1
     
203.       For Each bb In d3(k)(aa).keys
     
204.         frr = d3(k)(aa)(bb)
     
205.         ReDim brr(1 To UBound(frr, 2), 1 To UBound(frr))
     
206.         For i = 1 To UBound(frr)
     
207.           For j = 1 To UBound(frr, 2)
     
208.             brr(j, i) = frr(i, j)
     
209.           Next
     
210.         Next
     
211.         With Worksheets("模板")
     
212.           .Range("a6:k25").ClearContents
     
213.           .Range("n6:n9").ClearContents
     
214.           .Range("l2") = aa
     
215.           .Range("l3") = Application.Sum(Application.Index(brr, 0, 11))
     
216.           .Range("j3") = DX(.Range("l3"))
     
217.           .Range("n6") = Application.Sum(Application.Index(brr, 0, 6)) & "张(份)"
     
218.           .Range("n7") = Application.Sum(Application.Index(brr, 0, 7)) & "张(份)"
     
219.           .Range("n8") = Application.Sum(Application.Index(brr, 0, 8)) & "张(份)"
     
220.           .Range("n9") = Application.Sum(Application.Index(brr, 0, 9)) & "张(份)"
     
221.           .Range("a6").Resize(UBound(brr), UBound(brr, 2)) = brr
     
222.           .Range("a1:n26").Copy Worksheets(aa).Cells(m, 1)
     
223.         End With
     
224.         With Worksheets(aa)
     
225.           For i = 1 To UBound(hg)
     
226.             .Rows(m + i - 1).RowHeight = hg(i)
     
227.           Next
     
228.         End With
     
229.         m = m + 27
     
230.       Next
     
231.       With Worksheets(aa)
     
232.         For j = 1 To UBound(lk)
     
233.           .Columns(j).ColumnWidth = lk(j)
     
234.         Next
     
235.       End With
     
236.     Next
     
237.   Next
     
238. End Sub
     

复制代码