关于会计科目 逐级汇总的问题

zymwhy

请各位老师百忙之中，给予指点一下。多谢！

chaohuahch

代码如下，如果要扩展的话，目前没有什么想法，不过要是知道总共有多少级的话，程序还是可以一次写好的。

1. Sub 汇总()
   
2. Dim arr, brr(), m#, mm#, n#, i%, j%
   
3. Dim m3#, mm3#, mm2#, m2#
   
4. arr = [a1].CurrentRegion
   
5. 
   
6.     For j = UBound(arr) To 1 Step -1
   
7.      If arr(j, UBound(arr, 2)) = "四级科目" Then
   
8.         m = m + arr(j, 5): mm = mm + arr(j, 6)
   
9.      ElseIf arr(j, UBound(arr, 2)) = "三级科目" Then
   
10.         arr(j, 5) = m: arr(j, 6) = mm
    
11.         m3 = m3 + m: mm3 = mm3 + mm
    
12.         m = 0: mm = 0
    
13.      ElseIf arr(j, UBound(arr, 2)) = "二级科目" Then
    
14.         arr(j, 5) = m3: arr(j, 6) = mm3
    
15.         m2 = m2 + m3: mm2 = mm2 + mm3
    
16.      ElseIf arr(j, UBound(arr, 2)) = "一级科目" Then
    
17.         arr(j, 5) = m2: arr(j, 6) = mm2
    
18.      End If
    
19.     Next j
    
20. Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
21. 
    
22. End Sub

复制代码

jjmysjg

chaohuahch 发表于 2018-7-30 19:48
代码如下，如果要扩展的话，目前没有什么想法，不过要是知道总共有多少级的话，程序还是可以一次写好的。
...

可否根据科目编号的位数确定科目级次进而汇总？

zymwhy

chaohuahch 发表于 2018-7-30 19:48
代码如下，如果要扩展的话，目前没有什么想法，不过要是知道总共有多少级的话，程序还是可以一次写好的。
...

谢谢老师你给予的回复，我要说明是：上传的表格中那些 科目属于几级的是我作的备注说明的，如果没有这些说明如何能做到逐级汇总呢？谢谢

cqcbc

提问的时候，无限接近原始资料，免得老师们做一些无用功，这是我的一点儿心得。

fsq119

试试
Sub 树状分级汇总()
ReDim Str(1 To 3), s(1 To 3)
s(1) = "选中“级数”所在列单元格"
s(2) = "选中“值”所在列单元格"
s(3) = "选中“结果”所在列单元格"
For i = 1 To 3
Str(i) = Application.InputBox(s(i), Type:=8).Address
With CreateObject("vbscript.regexp")
.Pattern = "^\$([A-Z]+).*"
Str(i) = .Replace(Str(i), "$1")
End With
Next
c_ji = Str(1)
c_zhi = Str(2)
c_xie = Str(3)
Application.ScreenUpdating = False
qd = range(c_ji & 1).End(xlDown).Row
zd = range(c_ji & 65536).End(xlUp).Row
Set dic = CreateObject("scripting.dictionary")
Cells.ClearOutline
ActiveSheet.Outline.SummaryRow = xlAbove
For i = qd To zd
    j_now = range(c_ji & i)
    j_next = range(c_ji & i + 1)
    ActiveSheet.Rows(i).OutlineLevel = j_now
    If j_now < j_next Then
        dic(i) = j_now
    ElseIf j_now > j_next Then
        arr = dic.keys
        For j = UBound(arr) To LBound(arr) Step -1
            If dic(arr(j)) < j_next Then Exit For
            With range(c_xie & arr(j))
                .Formula = "=subtotal(9," & c_xie & arr(j) + 1 & ":" & c_xie & i & ")"
                .Interior.ColorIndex = 6
            End With
            dic.Remove arr(j)
        Next
    End If
Next
Set dic = Nothing
Application.ScreenUpdating = True
End Sub

fsq119

fsq119 发表于 2018-7-31 11:56
试试
Sub 树状分级汇总()
ReDim Str(1 To 3), s(1 To 3)

需要辅助列填写级数1，2，3……，就是几级科目