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

zh2783458

请问老师：怎样用VBA根据AH列的一二级科目名称和AA列的月份，在摘要说明列(AS列)中插入本月合计和本年累计来统计AI列借方金额和AJ列贷方金额？谢谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(1 To 2, 35 To 36) As Double
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets(1)
   
7.     r = .Cells(.Rows.Count, "aa").End(xlUp).Row
   
8.     i = 4
   
9.     Do Until .Cells(i, 31) <> "期初余额"
   
10.       i = i + 1
    
11.     Loop
    
12.     For j = 35 To 36
    
13.       brr(1, j) = Val(.Cells(i, j))
    
14.       brr(2, j) = Val(.Cells(i, j))
    
15.     Next
    
16.     i = i + 1
    
17.     Do While .Cells(i, 33) <> ""
    
18.       If .Cells(i, 34) = .Cells(i - 1, 34) Then
    
19.         If .Cells(i, 27) = .Cells(i - 1, 27) Then
    
20.           For j = 35 To 36
    
21.             brr(1, j) = brr(1, j) + Val(.Cells(i, j))
    
22.           Next
    
23.         Else
    
24.           .Rows(i).Insert shift:=xlDown
    
25.           .Cells(i, 31) = "本月合计"
    
26.           .Cells(i, 34) = .Cells(i - 1, 34)
    
27.           .Cells(i, 35).Resize(1, 2) = Application.Index(brr, 1, 0)
    
28.           .Rows(i + 1).Insert shift:=xlDown
    
29.           .Cells(i + 1, 31) = "本年累计"
    
30.           .Cells(i + 1, 34) = .Cells(i - 1, 34)
    
31.           .Cells(i + 1, 35).Resize(1, 2) = Application.Index(brr, 2, 0)
    
32.           For j = 35 To 36
    
33.             brr(1, j) = Val(.Cells(i + 2, j))
    
34.           Next
    
35.           i = i + 2
    
36.         End If
    
37.         For j = 35 To 36
    
38.           brr(2, j) = brr(2, j) + Val(.Cells(i, j))
    
39.         Next
    
40.       Else
    
41.         .Rows(i).Insert shift:=xlDown
    
42.         .Cells(i, 31) = "本月合计"
    
43.         .Cells(i, 34) = .Cells(i - 1, 34)
    
44.         .Cells(i, 35).Resize(1, 2) = Application.Index(brr, 1, 0)
    
45.         .Rows(i + 1).Insert shift:=xlDown
    
46.         .Cells(i + 1, 31) = "本年累计"
    
47.         .Cells(i + 1, 34) = .Cells(i - 1, 34)
    
48.         .Cells(i + 1, 35).Resize(1, 2) = Application.Index(brr, 2, 0)
    
49.         For k = 1 To 2
    
50.           For j = 35 To 36
    
51.             brr(k, j) = Val(.Cells(i + 2, j))
    
52.           Next
    
53.         Next
    
54.         i = i + 2
    
55.       End If
    
56.       i = i + 1
    
57.     Loop
    
58.     .Cells(i, 31) = "本月合计"
    
59.     .Cells(i, 34) = .Cells(i - 1, 34)
    
60.     .Cells(i, 35).Resize(1, 2) = Application.Index(brr, 1, 0)
    
61.     .Cells(i + 1, 31) = "本年累计"
    
62.     .Cells(i + 1, 34) = .Cells(i - 1, 34)
    
63.     .Cells(i + 1, 35).Resize(1, 2) = Application.Index(brr, 2, 0)
    
64.   End With
    
65. End Sub
    
66. 
    

复制代码

chxw68

前几天刚写过一个类似的。

iwangyi

学习累积汇总

zh2783458

chxw68 发表于 2018-9-6 11:44
前几天刚写过一个类似的。

谢谢chxw68老师的回答，AH列中的一二级科目名称在0月份的时候，没有分开。我想达到附件右边的效果，也就是说按一二级科目名称相同的和月份升序来排序，谢谢！

zh2783458

chxw68 发表于 2018-9-6 11:44
前几天刚写过一个类似的。

谢谢chxw68老师的回答，AH列中的一二级科目名称在0月份的时候，没有分开。我想达到附件右边的效果，也就是说按一二级科目名称相同的和月份升序来排序，谢谢！

chxw68

zh2783458 发表于 2018-9-6 12:35
谢谢chxw68老师的回答，AH列中的一二级科目名称在0月份的时候，没有分开。我想达到附件右边的效果，也就 ...

这个需要用字典了！你是不是有两个注册名字？前几天解答的问题跟你这个百分之九十九相似。

zh2783458

chxw68 发表于 2018-9-6 14:43
这个需要用字典了！你是不是有两个注册名字？前几天解答的问题跟你这个百分之九十九相似。

谢谢老师！我只有一个注册名字，在8月22日用这个名字和这个附件问过另外一种形式的本月合计和本年累计，当时是iwangyi老师给我回答过，但没完全达到我想要的这种形式，谢谢以上两位老师的回答。

chxw68

zh2783458 发表于 2018-9-6 21:11
谢谢老师！我只有一个注册名字，在8月22日用这个名字和这个附件问过另外一种形式的本月合计和本年累计， ...

前面为什么隐藏这么多列呢？

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), 35).Resize(1, 2).FormulaR1C1 = "=SUM(R" & m & "C:R[-1]C)"
    
44.           gs = gs & "+" & "R" & m + UBound(brr) & "C"
    
45.           .Cells(m + UBound(brr) + 1, 31) = "本年累计"
    
46.           .Cells(m + UBound(brr) + 1, 35).Resize(1, 2).FormulaR1C1 = "=" & Mid(gs, 2)
    
47.           m = m + UBound(brr) + 2
    
48.         Else
    
49.           m = m + UBound(brr)
    
50.         End If
    
51.       Next
    
52.     Next
    
53.   End With
    
54. End Sub

复制代码