按科目级次自动累进求和，并能方便的生成公式

haitaozhe

由于工作需要，有一个在excel中的分级次自动求和，并生成公式的问题，请各位高手帮忙，这个问题困惑我很久了，谢谢！

Admin

   

很遗憾通知楼上朋友，您的帖子在24小时之内没有任何回复！

通常情况下，本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复，其中的原因可能是：

1、问题表述不清、模棱两可，难以理解，帮助者被搞晕了，夺帖而出；
2、没有上传必要的附件，或附件被遗忘在某个角落；
3、发帖提问时，语气带棱角、带挑衅，不幸被列入不受欢迎的帖子；
4、所提问题不成立，或提不合理的要求，乐于助人者使出“走为上”之计；
5、话题较偏、较冷或者发布到了不合适的版块，暂时无人问津，顾影自怜。


为了提高您的问题解决效率，我们推荐您阅读以下文章：
* 如何发表新话题和上传附件：http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧：http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法：http://club.excelhome.net/thread-117862-1-1.html

wangjguo44

笨办法抛砖引玉，试试这一个
（1.A列中红底A283、A461两个是原表没有代码的，计算会出错，故胡凑了一个代码；
2.有的没有下级编码的，如276行、282行、283行等，目前在对应C列里保留公式，可直接输入数据）

haitaozhe

你好，楼上的附件我下了，也看了，但是不是很明白，不过我想问的是在这个表中的需要求合计的数据行中，每个公式都要输一次吗，还是一次性就把公式全部搞定的

haitaozhe

哦，谢谢3楼 悠游独钓客 的帮助，我虽然不是很明白现正在学习中！

wangjguo44

我的公式比较笨，输数据有两个方法：
1.如果数据可以后输的话，可以一次性先在C7输入公式并下拉到715行，然后在需要输数据的单元格里输入数据；
2.如果已有数据且不方便改变，也可以先在C7输入公式，再把需要输公式的单元格（如附件中由条件格式而变成粉色底的单元格）全部点上，一次性把C7的公式复制粘贴上去

萧瑟7964

看看，学习，我也在找这个问题的答案

sdjnxsl

Public First_H As Integer  '记录该级次出现第一次行号

Sub QHGS()

'##############
'生成求和公式
'##############

    Dim SourceSheetName As String
    Dim StartRow As Integer
    Dim EndRow As Integer
    Dim Table_ZBT As String
    Dim Formula_Col As String
   
    On Error GoTo ERROR_QHGS
        
    '增加Define工作表、可见、删除原来数据
    Bm3AddSheet ("Define")
    Sheets("Define").Visible = True
   
    SourceSheetName = ActiveWorkbook.ActiveSheet.Name
   
    StartRow = 4
    EndRow = 20
    Table_ZBT = "A"
    Formula_Col = "B"
   
    With Workbooks(BMDLG).DialogSheets("Xsl_Dlg_SCGS")
        
        .EditBoxes("Label_ZBT_Col").Text = Table_ZBT '纵表头所在列
        .EditBoxes("Label_SJ_Col").Text = Formula_Col  '公式所在列
        .EditBoxes("Label_SJ_StartRow").Text = StartRow  '数据开始行
        .EditBoxes("Label_SJ_EndRow").Text = EndRow  '数据结束列
        
        If .Show Then   '要用if……end if语句，不然，点击“取消”仍执行程序
              
              '提取用户选项
              Table_ZBT = .EditBoxes("Label_ZBT_Col").Text  '纵表头所在列
              Formula_Col = .EditBoxes("Label_SJ_Col").Text   '公式所在列
              StartRow = .EditBoxes("Label_SJ_StartRow").Text   '数据开始行
              EndRow = .EditBoxes("Label_SJ_EndRow").Text   '数据结束列
         
             'Copy纵表头信息并删除末尾空格
                                          
              If .OptionButtons("Radio_KG").Value = 1 Then
                 '生成级次——前空格
                  For i = StartRow To EndRow
                       Sheets("Define").Cells(i, 1) = VBA.RTrim(Sheets(SourceSheetName).Cells(i, Table_ZBT)) '将标志所在列压缩右空格后拷入Define表
                       Sheets("Define").Cells(i, 2) = Len(Sheets(SourceSheetName).Cells(i, Table_ZBT)) - Len(VBA.LTrim(Sheets(SourceSheetName).Cells(i, Table_ZBT))) + 1  '得到层级：原始长度－压缩左空格长度＋1
                  Next
              End If
              
              If .OptionButtons("Radio_SJ").Value = 1 Then
                  '生成级次——前缩进
                  For i = StartRow To EndRow
                        Sheets("Define").Cells(i, 2) = Sheets(SourceSheetName).Cells(i, Table_ZBT).IndentLevel + 1
                  Next
              End If
              
              If .OptionButtons("Radio_DM").Value = 1 Then
                  '生成级次——代码
                  For i = StartRow To EndRow
                        Sheets("Define").Cells(i, 2) = Len(Sheets(SourceSheetName).Cells(i, Table_ZBT))  '将原表代码长度放入Define的第2列
                  Next
              End If
              
              '判断级次Step是否为1
              If Sheets("Define").Cells(StartRow + 1, 2) - Sheets("Define").Cells(StartRow, 2) <> 1 Then
                 Dim StepNum As Integer
                 StepNum = Sheets("Define").Cells(StartRow + 1, 2) - Sheets("Define").Cells(StartRow, 2)  '取得步长：下一行－上一行
                 
                 Select Case StepNum
                     Case 2
                       'MsgBox "Step=" & StepNum
                       For qw = StartRow + 1 To EndRow
                          Sheets("Define").Cells(qw, 3).Formula = "=round(" & Sheets("Define").Cells(qw, 2) & "/2,0)"    '在第3列算出步长为1的级次
                          Sheets("Define").Cells(qw, 2) = Sheets("Define").Cells(qw, 3).Value    '拷入第2列
                       Next
                 End Select
                 
              End If
        
              '纵表头下空一行放级次最大数，并赋予变量
              
              Sheets("Define").Cells(EndRow + 2, 1).Formula = "=Max(B" & StartRow & ":B" & EndRow & ")"
              Dim MaxJc As Integer
              MaxJc = Sheets("Define").Cells(EndRow + 2, 1)
              Dim JC As Integer
              
              For JC = 1 To MaxJc
              'For Jc = 8 To 8
                  If JC = 1 Then  '若是最高级1
                      Call GS(StartRow, EndRow, JC + 1, Formula_Col, SourceSheetName)
                  Else
                     
                     'If Jc = 2 Then
                        Dim Arry2()
                        Dim C As Integer
                        C = 0
                        For i = StartRow To EndRow '将整修区间中JC的个数找出
                            If Sheets("Define").Cells(i, 2) = JC Then
                               C = C + 1
                            End If
                        Next
                        
                        If Sheets("Define").Cells(EndRow, 2) <> JC Then '最后一行不是Jc
                               C = C + 1
                        End If
                        '以上得到Jc的个数
                        
                        ReDim Arry2(C)
                        K = 1
                        For i = StartRow To EndRow '将Jc的行号找出
                            If Sheets("Define").Cells(i, 2) = JC Then
                               Arry2(K) = Sheets("Define").Cells(i, 2).Row
                               K = K + 1
                            End If
                        Next
                        
                        If Sheets("Define").Cells(EndRow, 2) <> JC Then
                               Arry2(K) = EndRow
                        End If
                                                
                        For i = 1 To UBound(Arry2) - 1 '本级行号个数
                           
                            Dim L As Integer
                            Dim M As Integer
                                
                            For L = Arry2(i) To Arry2(i + 1)  '6→7　　7→10　10→14
                              
                                'If Arry2(i + 1) - Arry2(i) > 2 Then '确保中间至少空一行
                                    Call GS(Arry2(i), Arry2(i + 1), JC + 1, Formula_Col, SourceSheetName)
                                'End If
                                
                                '在此区间内计算3的个数
                                
                                If Sheets("Define").Cells(L, 2) = JC + 1 Then
                                   M = M + 1
                                End If

                            Next
                           
                            ReDim Arry(M) '用于存放3的数组
                            G = 1
                            For L = Arry2(i) To Arry2(i + 1)  '6→7　　7→10　10→14
                                If Sheets("Define").Cells(L, 2) = JC + 1 Then
                                   Arry(G) = Sheets("Define").Cells(L, 2).Row
                                   G = G + 1
                                End If
                            Next
                           
                            If M >= 1 Then
                           
                                Dim Y As Integer
                                
                                For Y = 1 To M - 1
                                   For R = Arry(Y) To Arry(Y + 1)
                                       If Arry(Y + 1) - Arry(Y) > 2 Then '确保区段之间至少有一行别的
                                           'MsgBox "区间：" & Arry(Y) & "→" & Arry(Y + 1) & " 传递的级次：" & Jc + 2
                                           Call GS(Arry(Y), Arry(Y + 1), JC + 2, Formula_Col, SourceSheetName)
                                       End If
                                   Next
                                Next
                                
                            End If
                           
                            M = 0
                           
                        Next
                  End If
              Next
        End If
    End With
   
    Sheets("Define").Activate
    'Cells.Select
    'Selection.Delete Shift:=xlUp
   
    Cells.Delete
   
    Sheets("Define").Visible = False
   
    Sheets(SourceSheetName).Activate
   
    Exit Sub
   
ERROR_QHGS:
    MsgBox "出现未知的错误,错误为(" + Err.Description + ")！"
End Sub

Sub GS(ByVal A As Integer, ByVal B As Integer, ByVal Flag As Integer, ByVal Col As String, ByVal SheetName As String)
   
    On Error GoTo Error_GS
    Dim Formula_String As String
   
    For J = A To B
            If Sheets("Define").Cells(J, 2) = Flag Then
               Formula_String = Formula_String & Col & J & "+"
            End If
    Next
     
    If Formula_String <> "" Then
        Formula_String = Left(Formula_String, Len(Formula_String) - 1)
        Sheets(SheetName).Cells(A, Col).Formula = "=" & Formula_String
    End If
   
    Exit Sub
   
Error_GS:
    MsgBox "出现未知的错误,错误为(" + Err.Description + ")！"
   
End Sub

sdjnxsl

以上程序用了很长时间才写出，确实要解决楼主提出的问题，是比较难的，我头都想大了。程序虽然有点笨，但能达到目的，我现在一直在用这段代码，希望对你有所帮助。

haitaozhe

我看到代码了,但是由于对代码不是很熟悉,不知如何使用.
而且不知能否把以上代码做成一个插件来使用.