请问老师：怎样用VBA在摘要说明列中插入本月合计和本年累计来统计金额？

chxw68

修改好了！用字典实现的，统计之前无须删除合计和累计行，不会重复合计和累计的。

zh2783458

chxw68 发表于 2018-9-6 21:47
修改好了！用字典实现的，统计之前无须删除合计和累计行，不会重复合计和累计的。

chxw68老师：怎样实现在本月合计和本年累计两行中，把一级科目和二级科目名称也一并填入(如附件）？谢谢！

chxw68

1. Sub test3()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("流水账")
   
7.     r = .Cells(.Rows.Count, 27).End(xlUp).Row
   
8.     arr = .Range("aa4:aj" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Right(arr(i, 5), 1) <> "计" Then
    
11.         If Not d.exists(arr(i, 8)) Then
    
12.           Set d(arr(i, 8)) = CreateObject("scripting.dictionary")
    
13.         End If
    
14.         If Not d(arr(i, 8)).exists(arr(i, 1)) Then
    
15.           m = 1
    
16.           ReDim brr(1 To UBound(arr, 2), 1 To m)
    
17.         Else
    
18.           brr = d(arr(i, 8))(arr(i, 1))
    
19.           m = UBound(brr, 2) + 1
    
20.           ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
    
21.         End If
    
22.         For j = 1 To UBound(arr, 2)
    
23.           brr(j, m) = arr(i, j)
    
24.         Next
    
25.         d(arr(i, 8))(arr(i, 1)) = brr
    
26.       End If
    
27.     Next
    
28.     .Range("aa4:aj" & r).ClearContents
    
29.     m = 4
    
30.     For Each aa In d.keys
    
31.       gs = ""
    
32.       For Each bb In d(aa).keys
    
33.         arr = d(aa)(bb)
    
34.         ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
    
35.         For i = 1 To UBound(arr)
    
36.           For j = 1 To UBound(arr, 2)
    
37.             brr(j, i) = arr(i, j)
    
38.           Next
    
39.         Next
    
40.         .Cells(m, 27).Resize(UBound(brr), UBound(brr, 2)) = brr
    
41.         If bb <> 0 Then
    
42.           .Cells(m + UBound(brr), 31) = "本月合计"
    
43.           .Cells(m + UBound(brr), 32) = Split(aa, "-")(0)
    
44.           .Cells(m + UBound(brr), 33) = Split(aa, "-")(1)
    
45.           .Cells(m + UBound(brr), 34) = aa
    
46.           .Cells(m + UBound(brr), 35).Resize(1, 2).FormulaR1C1 = "=SUM(R" & m & "C:R[-1]C)"
    
47.           gs = gs & "+" & "R" & m + UBound(brr) & "C"
    
48.           .Cells(m + UBound(brr) + 1, 31) = "本年累计"
    
49.           .Cells(m + UBound(brr) + 1, 32) = Split(aa, "-")(0)
    
50.           .Cells(m + UBound(brr) + 1, 33) = Split(aa, "-")(1)
    
51.           .Cells(m + UBound(brr) + 1, 34) = aa
    
52.           .Cells(m + UBound(brr) + 1, 35).Resize(1, 2).FormulaR1C1 = "=" & Mid(gs, 2)
    
53.           m = m + UBound(brr) + 2
    
54.         Else
    
55.           m = m + UBound(brr)
    
56.         End If
    
57.       Next
    
58.     Next
    
59.   End With
    
60. End Sub
    
61. 
    
62. 
    

复制代码

chxw68

修改好了。

zh2783458

chxw68 发表于 2018-9-7 07:44
修改好了。

chxw68老师：完全符合我的要求，多次耐心的讲解，十分的感谢，论坛有您们这些人无私的奉献，一定会更加美好！