利用vba进行会计科目汇总

cheree

利用vba对会计科目汇总，输入最末级的科目的金额（白色部分），然后能得到每一级的汇总数量（黄色），应该怎么做呢

ccwan

1. Sub cc()
   
2.     Dim arr, rng, i%, j%, num1&, num2&, num3&, a As Boolean
   
3.     arr = Range("a1:b" & [a1048576].End(3).Row)
   
4.     For i = UBound(arr) To 1 Step -1
   
5.         Do While Left(arr(i, 1), 1) = Left(arr(i - 1, 1), 1)
   
6.             rng = Split(arr(i, 1), ".")
   
7.             If UBound(rng) = 2 Then
   
8.                 num1 = num1 + arr(i, 2)
   
9.             End If
   
10.             If UBound(rng) = 1 Then
    
11.                 num2 = num2 + num1
    
12.                 num1 = 0
    
13.                 a = True
    
14.             End If
    
15.             If a = True Then
    
16.                 arr(i, 2) = num2
    
17.                 num3 = num3 + num2
    
18.                 num2 = 0
    
19.                 a = False
    
20.             End If
    
21.             i = i - 1
    
22.             If i = 1 Then Exit Do
    
23.         Loop
    
24.         arr(i, 2) = num3
    
25.         num3 = 0
    
26.     Next
    
27.     [b1].Resize(UBound(arr)) = Application.Index(arr, , 2)
    
28. End Sub

复制代码

ccwan

审核中，发附件吧

ccwan

重新改一下，整复杂了

1. Sub cc()
   
2.     Dim arr, rng, i%, j%, num1&, num2&, num3&, a As Boolean
   
3.     arr = Range("a1:b" & [a1048576].End(3).Row)
   
4.     For i = UBound(arr) To 1 Step -1
   
5.         Do While Left(arr(i, 1), 1) = Left(arr(i - 1, 1), 1)
   
6.             rng = Split(arr(i, 1), ".")
   
7.             If UBound(rng) = 2 Then
   
8.                 num1 = num1 + arr(i, 2)
   
9.             End If
   
10.             If UBound(rng) = 1 Then
    
11.                 num2 = num2 + num1
    
12.                 num1 = 0
    
13.                 arr(i, 2) = num2
    
14.                 num3 = num3 + num2
    
15.                 num2 = 0
    
16.             End If
    
17.             i = i - 1
    
18.             If i = 1 Then Exit Do
    
19.         Loop
    
20.         arr(i, 2) = num3
    
21.         num3 = 0
    
22.     Next
    
23.     [c1].Resize(UBound(arr)) = Application.Index(arr, , 2)
    
24. End Sub

复制代码

wdwlywpl

学习了，谢谢分享

cheree

ccwan 发表于 2020-6-24 19:52
审核中，发附件吧

非常感谢！，那如果不止三级，有四级五级这种怎么做呢

笨鸟飞不高

Sub AwTest()
    Dim i%, iStr$, arr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr)
        If Len(arr(i, 1)) = 3 Then
            d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
        Else
            d(Left(arr(i, 1), 3)) = d(Left(arr(i, 1), 3)) + arr(i, 2)
            d(Left(arr(i, 1), 1)) = d(Left(arr(i, 1), 1)) + arr(i, 2)
        End If
    Next
    For i = 1 To UBound(arr)
        If Len(arr(i, 2)) = 0 Then iStr = arr(i, 1): arr(i, 2) = d(iStr)
    Next
    [a1].CurrentRegion = arr
End Sub

凑一个！！

cheree

笨鸟飞不高 发表于 2020-6-24 21:54
Sub AwTest()
    Dim i%, iStr$, arr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
...

如果不是从a1单元格开始，而是窗口先询问需要合并的会计科目区域，以及金额合并的区域，然后根据这个区域计算，应该怎么写代码呢

笨鸟飞不高

cheree 发表于 2020-6-24 22:13
如果不是从a1单元格开始，而是窗口先询问需要合并的会计科目区域，以及金额合并的区域，然后根据这个区域 ...

选择区域赋给数组，试试！！！
arr=Selection....
有问题，有要求可以上传附件！！！

cheree

笨鸟飞不高 发表于 2020-6-24 22:20
选择区域赋给数组，试试！！！
arr=Selection....
有问题，有要求可以上传附件！！！

就是想用set arr1 = Application.InputBox("请选择科目代码区域:", Type:=8)，Set arr2 = Application.InputBox("请选择求和金额区域:", Type:=8)选择区域，但是之后怎么给arr赋值，最后怎么将值按照之前选择的区域放置呢，我把文件链接放下一楼回复吧