Excel·VBA选中列一键计算小计总计

不同于《Excel·VBA一键计算每月合计》，仅对指定关键字计算合计数，而本文可以实现对选中列自动插入小计、总计行并求和

连续相同关键值自动小计

自动插入小计、总计行，对关键值列中连续相同值的行，对选中列进行小计，并最后总计

Sub 选中列一键计算小计总计_关键值()
    '对关键值列中连续相同值的行，对选中列进行小计，并最后总计
    '适用单/多列选中、单/多列部分选中；部分选中时，选中区域不得与表头行重叠，避免计算错误
    Dim key_col&, title_row&, rng As Range, i&, j&, k&
    Dim first_row&, last_row&, first_col&, last_col&, start_row&, end_row&
'--------------------参数填写：key_col、title_row都为数字
    key_col = 1    '关键值号，对连续相同的进行小计；空值不影响
    title_row = 1  '表头行数，不进行计算；0即为全部计算
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    first_row = rng.row     '选中区域开始行号
    last_row = first_row + rng.Rows.Count - 1  '选中区域结束行号
    first_col = rng.column  '选中区域开始列号
    last_col = first_col + rng.Columns.Count - 1  '选中区域结束列号
    
    With ActiveSheet
        '总计
        .Rows(last_row + 1).Insert  '选中末行插入
        .Cells(last_row + 1, key_col) = "总计": r = last_row - first_row + 1  '总行数
        For i = first_col To last_col
            If title_row >= first_row Then  '整列选中，或部分选中时包含表头
                .Cells(last_row + 1, i).FormulaR1C1 = "=SUM(R[-" & r - title_row & "]C:R[-1]C)"
            Else  '部分选中，且不包含表头
                .Cells(last_row + 1, i).FormulaR1C1 = "=SUM(R[-" & r & "]C:R[-1]C)"
            End If
        Next
        '清除公式仅保留结果，避免被后续小计的值干扰
        .Cells(last_row + 1, first_col).Resize(1, last_col - first_col + 1) = .Cells(last_row + 1, first_col).Resize(1, last_col - first_col + 1).Value
        '小计
        If first_row > title_row Then start_row = first_row Else start_row = title_row + 1
        end_row = last_row + 1  '因总计行，总行数+1
        Do
            For j = start_row + 1 To end_row
                If .Cells(start_row, key_col) <> .Cells(j, key_col) Then
                    .Rows(j).Insert
                    .Cells(j, key_col) = .Cells(j - 1, key_col).Value & "-小计"
                    For k = first_col To last_col
                        .Cells(j, k).FormulaR1C1 = "=SUM(R[-" & j - start_row & "]C:R[-1]C)"
                    Next
                    '也可清除公式仅保留结果
                    Range(.Cells(j, first_col), .Cells(j, last_col)).Value = Range(.Cells(j, first_col), .Cells(j, last_col)).Value
                    start_row = j + 1: end_row = end_row + 1  '开始、结束行号更新值
                    Exit For  '结束for循环
                End If
            Next
        Loop Until start_row >= end_row
    End With
    Debug.Print "小计、总计行插入完成"
End Sub

举例

参数：key_col = 1，title_row = 1，选中C列运行代码，结果：

固定行数分段自动小计

Sub 选中列一键计算小计总计_分段()
    '对选中列按固定行数进行小计，并最后总计
    '适用单/多列选中、单/多列部分选中；部分选中时，选中区域不得与表头行重叠，避免计算错误
    Dim key_col&, title_row&, split_row&, rng As Range, i&, j&, k&
    Dim first_row&, last_row&, first_col&, last_col&, start_row&, end_row&, split_last&
'--------------------参数填写：key_col、title_row、split_row都为数字
    key_col = 1    '小计、总计，所在列号
    title_row = 1  '表头行数，不进行计算；0即为全部计算
    split_row = 8  '按固定行数分段小计
    Set rng = Intersect(ActiveSheet.UsedRange, Selection)  'intersect语句避免选择整列造成无用计算
    first_row = rng.row     '选中区域开始行号
    last_row = first_row + rng.Rows.Count - 1  '选中区域结束行号
    first_col = rng.column  '选中区域开始列号
    last_col = first_col + rng.Columns.Count - 1  '选中区域结束列号
    
    With ActiveSheet
        '总计
        .Rows(last_row + 1).Insert  '选中末行插入
        .Cells(last_row + 1, key_col) = "总计": r = last_row - first_row + 1  '总行数
        For i = first_col To last_col
            If title_row >= first_row Then  '整列选中，或部分选中时包含表头
                .Cells(last_row + 1, i).FormulaR1C1 = "=SUM(R[-" & r - title_row & "]C:R[-1]C)"
            Else  '部分选中，且不包含表头
                .Cells(last_row + 1, i).FormulaR1C1 = "=SUM(R[-" & r & "]C:R[-1]C)"
            End If
        Next
        .Cells(last_row + 1, first_col).Resize(1, last_col - first_col + 1) = .Cells(last_row + 1, first_col).Resize(1, last_col - first_col + 1).Value
        '小计
        If first_row > title_row Then start_row = first_row Else start_row = title_row + 1
        end_row = last_row + 1  '因总计行，总行数+1
        split_last = (end_row - start_row) Mod split_row  '最后一个非完整分段行数
        Do
            If start_row + split_row <= end_row Then  '非最后一个分段，或完整分段
                j = start_row + split_row: offset_row = split_row
            Else  '最后一个非完整分段
                j = end_row: offset_row = split_last
            End If
            .Rows(j).Insert
            .Cells(j, key_col) = "小计"
            For k = first_col To last_col
                .Cells(j, k).FormulaR1C1 = "=SUM(R[-" & offset_row & "]C:R[-1]C)"
            Next
            '也可清除公式仅保留结果
            'Range(.Cells(j, first_col), .Cells(j, last_col)).Value = Range(.Cells(j, first_col), .Cells(j, last_col)).Value
            start_row = j + 1: end_row = end_row + 1  '开始、结束行号更新值
        Loop Until start_row >= end_row
    End With
    Debug.Print "小计、总计行插入完成"
End Sub

结果：
参数：key_col = 1，title_row = 1，split_row = 8，选中C列运行代码，结果与上面举例的效果一致