请求编写实现多工作表动态行列自动求和的VBA代码

嗨，我完全懂你手动复制粘贴公式有多折磨人！下面这段VBA代码完美适配你的需求，能自动帮你完成所有工作表的行列求和操作，再也不用重复那些机械步骤了：

Sub AutoSumIncomeStatement()
    Dim ws As Worksheet
    Dim lastCol As Long, lastRow As Long
    Dim totalRow As Range
    Dim grandTotalCol As Long
    
    ' 遍历工作簿里的每一张工作表
    For Each ws In ThisWorkbook.Worksheets
        With ws
            ' 获取数据区域的最后一列和最后一行（以A列为准定位最后行）
            lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            
            ' --------------------------
            ' 1. 处理月份合计列（Jan Total/Feb Total等列的Total行）
            ' --------------------------
            Set totalRow = .Columns("A").Find(What:="Total", After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext)
            Do While Not totalRow Is Nothing
                ' 记录第一个找到的Total行，避免无限循环
                Dim firstTotalRow As Long
                firstTotalRow = totalRow.Row
                
                ' 遍历所有列，识别月份合计列（标题含"Total"）
                For col = 2 To lastCol - 1
                    If InStr(.Cells(1, col).Value, "Total") > 0 And .Cells(1, col).Value <> "Grand Total" Then
                        ' 找到当前合计列左边的明细列范围（从上个合计列的下一列到当前列的前一列）
                        Dim prevTotalCol As Long
                        prevTotalCol = col - 1
                        Do While prevTotalCol >= 2 And InStr(.Cells(1, prevTotalCol).Value, "Total") = 0
                            prevTotalCol = prevTotalCol - 1
                        Loop
                        prevTotalCol = prevTotalCol + 1
                        
                        ' 写入求和公式
                        .Cells(totalRow.Row, col).Formula = "=SUM(" & .Cells(totalRow.Row, prevTotalCol).Address & ":" & .Cells(totalRow.Row, col - 1).Address & ")"
                    End If
                Next col
                
                ' 定位下一个Total行
                Set totalRow = .Columns("A").FindNext(totalRow)
                ' 如果回到第一个Total行，退出循环
                If totalRow.Row = firstTotalRow Then Exit Do
            Loop
            
            ' --------------------------
            ' 2. 处理Grand Total列（求和所有月份合计值）
            ' --------------------------
            On Error Resume Next
            grandTotalCol = .Rows(1).Find(What:="Grand Total", LookIn:=xlValues, LookAt:=xlWhole).Column
            On Error GoTo 0
            
            If grandTotalCol > 0 Then
                Set totalRow = .Columns("A").Find(What:="Total", After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext)
                Do While Not totalRow Is Nothing
                    Dim firstMonthTotalCol As Long, lastMonthTotalCol As Long
                    ' 找到第一个和最后一个月份合计列
                    firstMonthTotalCol = .Rows(1).Find(What:="Total", After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext).Column
                    lastMonthTotalCol = .Rows(1).Find(What:="Total", After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious).Column
                    
                    ' 写入Grand Total求和公式
                    .Cells(totalRow.Row, grandTotalCol).Formula = "=SUM(" & .Cells(totalRow.Row, firstMonthTotalCol).Address & ":" & .Cells(totalRow.Row, lastMonthTotalCol).Address & ")"
                    
                    Set totalRow = .Columns("A").FindNext(totalRow)
                    If totalRow.Row = .Columns("A").Find(What:="Total", After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext).Row Then Exit Do
                Loop
            End If
            
            ' --------------------------
            ' 3. 处理行合计（A列Total行求和上方明细行）
            ' --------------------------
            Set totalRow = .Columns("A").Find(What:="Total", After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext)
            Do While Not totalRow Is Nothing
                Dim firstTotalRowRow As Long
                firstTotalRowRow = totalRow.Row
                
                ' 找到当前Total行上方的第一个非Total明细行
                Dim startRow As Long
                startRow = totalRow.Row - 1
                Do While startRow >= 1 And InStr(.Cells(startRow, "A").Value, "Total") > 0
                    startRow = startRow - 1
                Loop
                
                If startRow >= 1 Then
                    ' 在B列写入行求和公式
                    .Cells(totalRow.Row, 2).Formula = "=SUM(" & .Cells(startRow, 2).Address & ":" & .Cells(totalRow.Row - 1, 2).Address & ")"
                    ' 复制公式到右侧直到Grand Total列
                    .Cells(totalRow.Row, 2).Copy
                    .Range(.Cells(totalRow.Row, 2), .Cells(totalRow.Row, grandTotalCol)).PasteSpecial Paste:=xlPasteFormulas
                End If
                
                Set totalRow = .Columns("A").FindNext(totalRow)
                If totalRow.Row = firstTotalRowRow Then Exit Do
            Loop
            
            ' 清除剪贴板，避免残留复制状态
            Application.CutCopyMode = False
        End With
    Next ws
    
    MsgBox "所有工作表的自动求和操作已完成！", vbInformation
End Sub

使用说明： #

1. 打开你的利润表工作簿，按下Alt + F11打开VBA编辑器
2. 在左侧工程窗口右键点击你的工作簿名称，选择「插入」→「模块」
3. 把上面的代码粘贴到模块窗口里
4. 按下F5运行宏，或者回到Excel界面，通过「开发工具」→「宏」选择AutoSumIncomeStatement运行

自定义调整提示： #

• 如果你的Grand Total列标题不是"Grand Total"，可以修改代码里的What:="Grand Total"为你的实际标题
• 如果A列的合计行关键词不是"Total"，修改代码里的What:="Total"为对应的关键词就行

备注：内容来源于stack exchange，提问作者memo