Question

我想创建一个嵌套的小计宏，这意味着对“国家”列有一个小计，对于“城市”列有一个小计。我使用下面的代码来获取国家的小计，但是我不知道如何扩展代码以获得城市的小计。

我的代码中的一个条件是，总和公式应该存在于小计行中，以确保具有正确的范围。

我尝试了各种方法来获取城市的小计，但是总和公式的范围将随着宏插入新内容而创建，以创建新的小计。

我的想法是分两个步骤编写代码：

获取国家小计作为硬值--->具有硬值有助于避免公式失真，因为宏会为城市创建小计
获取城市小计作为总和公式这是我用来为国家/地区创建总和公式的小计的当前代码。

我用于为列国家/地区创建小计的代码：

Dim iCol As Integer 'number of columns
Dim i As Integer 'Macro starts from this row number
Dim j As Integer 'Macro continues with this row number in the loop

Worksheets("Example").Activate

Application.ScreenUpdating = False
i = 2 'starts from row 2
j = i
'Loops throught Col A Checking for match then when there is no match add Sum
Do While Range("A" & i) <> ""
    If Range("A" & i) <> Range("A" & (i + 1)) Then
        Rows(i + 1).Insert
        Range("A" & (i + 1)) = "Subtotal " & Range("A" & i).Value
        For iCol = 3 To 4 'Columns to Sum
            Cells(i + 1, iCol).Formula = "=SUM(R" & j & "C:R" & i & "C)"
        Next iCol
        Range(Cells(i + 1, 1), Cells(i + 1, 4)).Font.Bold = True
        Range(Cells(i + 1, 1), Cells(i + 1, 4)).Interior.Color = RGB(221, 237, 245)
        i = i + 2
        j = i
    Else
        i = i + 1
    End If
Loop
Application.ScreenUpdating = True

这是运行代码后我想要的屏幕截图。

这是我想要的输出

感谢您的帮助。

Answer 1

实际上这要复杂得多，就像：

它可以对无限的条件列和无限的小计和行执行此操作。只是不要忘记调整成本：

Const StartRow As Long = 2      'omit headers
Const CriteriaCount As Long = 3 'amount of criteria columns (here countries + cities + Houses)
Const SumtotalCount As Long = 3 'amount columns to sumtotal

代码：

Option Explicit

Public Sub CreateSubtotals()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Example")

    Const StartRow As Long = 2      'omit headers
    Const CriteriaCount As Long = 3 'amount of criteria columns (here countries + cities + Hauses)
    Const SumtotalCount As Long = 3 'amount columns to sumtotal

    Dim Criteria() As Variant
    Criteria = ws.Cells(StartRow, 1).Resize(ColumnSize:=CriteriaCount).Value

    ReDim StartRows(1 To CriteriaCount)
    Dim i As Long
    For i = LBound(StartRows) To UBound(StartRows)
        StartRows(i) = StartRow
    Next i

    Dim iRow As Long, iCol As Long
    iRow = StartRow + 1

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim RowsAdded As Long, CriteriaChanged As Boolean

    Do While iRow < LastRow + 2
        For iCol = CriteriaCount To 1 Step -1
            CriteriaChanged = False
            For i = 1 To iCol
                If Criteria(1, i) <> ws.Cells(iRow, i).Value Then CriteriaChanged = True
            Next i

            If CriteriaChanged Then
                ws.Rows(iRow).Insert
                RowsAdded = RowsAdded + 1

                ws.Cells(iRow, iCol).Value = "Subtotal " & Criteria(1, iCol)
                If iCol = CriteriaCount Then
                    ws.Cells(iRow, CriteriaCount + 1).Resize(ColumnSize:=SumtotalCount).Formula = "=Sum(" & ws.Cells(StartRows(iCol), CriteriaCount + 1).Resize(RowSize:=iRow - StartRows(iCol)).Address(True, False) & ")"
                Else
                    ws.Cells(iRow, CriteriaCount + 1).Resize(ColumnSize:=SumtotalCount).Formula = "=Sumif(" & ws.Cells(StartRows(iCol), iCol + 1).Resize(RowSize:=iRow - StartRows(iCol)).Address(True, True) & ",""Subtotal*""," & ws.Cells(StartRows(iCol), CriteriaCount + 1).Resize(RowSize:=iRow - StartRows(iCol)).Address(True, False) & ")"
                End If

                ws.Cells(iRow, iCol).Resize(ColumnSize:=SumtotalCount + CriteriaCount - iCol + 1).Interior.ThemeColor = 7 + iCol 'whatever you want

                For i = iCol To UBound(StartRows)
                    StartRows(i) = 0
                Next i
                iRow = iRow + 1
            End If
        Next iCol

        If RowsAdded <> 0 Then
            Criteria = ws.Cells(iRow, 1).Resize(ColumnSize:=CriteriaCount).Value
            For i = LBound(StartRows) To UBound(StartRows)
                If StartRows(i) = 0 Then StartRows(i) = iRow
            Next i

            LastRow = LastRow + RowsAdded 'if we insert a row we must increas last row
            RowsAdded = 0
        End If

        iRow = iRow + 1
    Loop
End Sub

在小计中插入和公式的多个（嵌套）小计VBA代码

1 个答案: