请大佬帮修改代码

dfjgm

需要给数据添加每页小计和每页累计，最后一页添加每页小计，每页累计和总计，但是弄出来最后会多出一个空白行和错误的本页小计，请大佬帮忙修改一下。

3190496160

Sub 分页小计()
Dim ar As Variant
Dim br()
Call 删除原有的分页小计行
ar = [a1].CurrentRegion
[a1].CurrentRegion.Offset(1).Font.Bold = False
[a1].CurrentRegion.Offset(1) = Empty
For i = 2 To UBound(ar) Step 14
    n = 0
    ReDim br(1 To 14, 1 To UBound(ar, 2))
    xj1 = 0: xj2 = 0: xj3 = 0
    For s = i To i + 13
        If s <= UBound(ar) Then
            n = n + 1
            xj1 = xj1 + ar(s, 5)
            xj2 = xj2 + ar(s, 6)
            xj3 = xj3 + ar(s, 7)
            lj1 = lj1 + ar(s, 5)
            lj2 = lj2 + ar(s, 6)
            lj3 = lj3 + ar(s, 7)
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(s, j)
            Next j
        End If
    Next s
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(r, 1).Resize(n, UBound(br, 2)) = br
    Cells(r, 1).Resize(n + 2, UBound(br, 2)).Borders.LineStyle = 1
    Cells(r + n, 1) = "本页小计"
    Cells(r + n, 5) = xj1
    Cells(r + n, 6) = xj2
    Cells(r + n, 7) = xj3
    Cells(r + n + 1, 1) = "本页累计"
    Cells(r + n + 1, 5) = lj1
    Cells(r + n + 1, 6) = lj2
    Cells(r + n + 1, 7) = lj3
    Cells(r + n, 1).Resize(2, 7).Font.Bold = True
Next i
MsgBox "ok!"
End Sub

3190496160

网格化小班表.rar (32.25 KB, 下载次数: 12)

2024-8-12 13:25 上传

点击文件名下载附件

3190496160

最后一页的本页累计就是总计，所以，没必要再添加一行总计，

dfjgm

3190496160 发表于 2024-8-12 13:24
Sub 分页小计()
Dim ar As Variant
Dim br()

非常感谢！

dfjgm

3190496160 发表于 2024-8-12 13:24
Sub 分页小计()
Dim ar As Variant
Dim br()

如果标题行是2行或以上，把For i = 2 To UBound(ar) Step 14改为For i = 3 To UBound(ar) Step 14，数据区计算是对的，但是会删除1行标题行，还需要改哪个语句

ykcbf1100

插入小计、插入累计、插入总计，公式法

ykcbf1100

插入小计公式法

1. Sub ykcbf()   '//2024.8.13   插入小计、每页累计、总计
   
2.     col = 2   '//基准列号
   
3.     c1 = 4    '//数据开始列号
   
4.     bt = 1    '//标题行号
   
5.     With Worksheets("Sheet1")
   
6.         r = .Cells(.Rows.Count, col).End(xlUp).Row
   
7.         c = .UsedRange.Find("*", SearchDirection:=2).Column
   
8.         m = r + 1
   
9.         b = [{4,5,6,7}]
   
10.         For i = r To bt + 1 Step -1
    
11.             If .Cells(i, col) <> .Cells(i - 1, col) Then
    
12.                 .Rows(m).Insert
    
13.                 .Cells(m, col) = "每页小计"
    
14.                 .Cells(m, c1).Resize(1, UBound(b)).Formula = "=SUM(D$" & i & ":D$" & m - 1 & ")"
    
15.                 .Rows(m + 1).Insert
    
16.                 .Cells(m + 1, col) = "每页累计"
    
17.                 .Cells(m + 1, c1).Resize(1, UBound(b)).Formula = "=SUMIFS(D$" & bt + 1 & ":D$" & m & ",$B" & bt + 1 & ":$B$" & m & ",""每页小计"")"
    
18.                 m = i
    
19.             End If
    
20.         Next
    
21.         r = .Cells(.Rows.Count, col).End(xlUp).Row
    
22.         .Cells(r + 1, col) = "总计"
    
23.         .Cells(r + 1, c1).Resize(1, UBound(b)).Formula = "=SUMIFS(D$" & bt + 1 & ":D$" & r & ",$B" & bt + 1 & ":$B$" & r & ",""每页小计"")"
    
24.         .Cells(1, 1).Resize(r + 1, c).Borders.LineStyle = 1
    
25.         ActiveWindow.DisplayZeros = False
    
26.     End With
    
27. End Sub

复制代码

kyxfyzg

Sub 新建分页小计()
    Dim iSubCol As Integer, rSubArea As Range
    Dim hb As HPageBreak

    Worksheets("sheet1").Activate              '激活工作表“sheet1”
    Rows(Range("a65536").End(xlUp).Row).Copy Range("a" & Range("a65536").End(xlUp).Row + 1)
    Rows(Range("a65536").End(xlUp).Row).ClearContents
    Range("a" & Range("a65536").End(xlUp).Row + 1) = " "
    ActiveWindow.View = xlPageBreakPreview  ' 进入 分页浏览 模式, 以便 EXCEL 正确计页
    Set r1stSubCell = Range("A2")           ' 本例名单从 A5 单元格开始
    iSubCol = 9                             ' 本例小计项共有 21 列

    ' 最后一行插入手工分页符
'    ActiveSheet.HPageBreaks.Add Before:=r1stSubCell.End(xlDown).Offset(1, 0)
'    ActiveSheet.HPageBreaks.Add Before:=Range("a65536").End(xlUp)

    ' 测试每一个分页符,
    ' 如果是自动分页符, 则在其上一行插入一小计行, 而本行纳入下一页
    ' 否则, 在本行插入一小计行
    For Each hb In ActiveSheet.HPageBreaks
        Set rCurrentCell = hb.Location
        rCurrentCell.Select                 ' 看看先

        If hb.Type = xlPageBreakAutomatic Then Set rCurrentCell = rCurrentCell.Offset(-2, 0)

        rCurrentCell.EntireRow.Insert
        rCurrentCell.EntireRow.Insert
        Set rCurrentCell = rCurrentCell.Offset(-2, 0)

        ' 添加分页小计内容
        With rCurrentCell
            .Value = "本页小计"
            .Font.Bold = True

            'Set rSubArea = Application.Union(Range("e" & rCurrentCell.Row), Range("g" & rCurrentCell.Row))  ' 需要填充分页小计公式的区域V列

            'Set rSubArea = Range("e" & rCurrentCell.Row, "g" & rCurrentCell.Row)  ' 需要填充分页小计公式的区域V列''B至V列的区域（共21列）
            r = rCurrentCell.Row
            Set rSubArea = Union(Range("e" & r), Range("f" & r), Range("g" & r)) ''填充分页小计公式的区域仅是其中3列（f、i、j)

            ' 使用 SUBTOTAL 公式的好处是方便扩展, 且不会对已计算区域重复计算(如果可能发生这种情况的话)
            rSubArea.Formula = "=SUBTOTAL(9," & r1stSubCell.Offset(0, 4).Address(1, 0) & ":" & .Offset(-1, 4).Address(1, 0) & ")"
            Set rCurrentCell = rCurrentCell.Offset(1, 0)
        End With
        With rCurrentCell
            .Value = "本页累计"
            .Font.Bold = True

            'Set rSubArea = Application.Union(Range("e" & rCurrentCell.Row), Range("g" & rCurrentCell.Row))  ' 需要填充分页小计公式的区域V列

            'Set rSubArea = Range("e" & rCurrentCell.Row, "g" & rCurrentCell.Row)  ' 需要填充分页小计公式的区域V列''B至V列的区域（共21列）
            r = rCurrentCell.Row
            Set rSubArea = Union(Range("e" & r), Range("f" & r), Range("g" & r)) ''填充分页小计公式的区域仅是其中3列（f、i、j)

            ' 使用 SUBTOTAL 公式的好处是方便扩展, 且不会对已计算区域重复计算(如果可能发生这种情况的话)
            rSubArea.Formula = "=SUBTOTAL(9," & "e2:" & .Offset(-1, 4).Address(1, 0) & ")"
            Set r1stSubCell = .Offset(1, 0)
        End With
    Next
    Rows(Range("a65536").End(xlUp).Row).Clear

    If Range("A65536").End(xlUp) = " " Then Rows(Range("a65536").End(xlUp).Row).Clear

    Rows(Range("a65536").End(xlUp).Row).Copy Range("a" & Range("a65536").End(xlUp).Row + 1)
    Rows(Range("a65536").End(xlUp).Row).Copy Range("a" & Range("a65536").End(xlUp).Row + 1)
    Rows(Range("a65536").End(xlUp).Row).Copy Range("a" & Range("a65536").End(xlUp).Row + 1)
    Rows(Range("a65536").End(xlUp).Row).ClearContents
    Rows(Range("a65536").End(xlUp).Row).ClearContents
    Rows(Range("a65536").End(xlUp).Row).ClearContents
        Set rCurrentCell = Range("a65536").End(xlUp).Offset(1, 0)
        With rCurrentCell
            .Value = "本页小计"
            .Font.Bold = True

            'Set rSubArea = Application.Union(Range("e" & rCurrentCell.Row), Range("g" & rCurrentCell.Row))  ' 需要填充分页小计公式的区域V列

            'Set rSubArea = Range("e" & rCurrentCell.Row, "g" & rCurrentCell.Row)  ' 需要填充分页小计公式的区域V列''B至V列的区域（共21列）
            r = rCurrentCell.Row
            Set rSubArea = Union(Range("e" & r), Range("f" & r), Range("g" & r)) ''填充分页小计公式的区域仅是其中3列（f、i、j)

            ' 使用 SUBTOTAL 公式的好处是方便扩展, 且不会对已计算区域重复计算(如果可能发生这种情况的话)
            rSubArea.Formula = "=SUBTOTAL(9," & r1stSubCell.Offset(0, 4).Address(1, 0) & ":" & .Offset(-1, 4).Address(1, 0) & ")"
            Set rCurrentCell = rCurrentCell.Offset(1, 0)
        End With
        
        With rCurrentCell
            .Value = "本页累计"
            .Font.Bold = True

            'Set rSubArea = Application.Union(Range("e" & rCurrentCell.Row), Range("g" & rCurrentCell.Row))  ' 需要填充分页小计公式的区域V列

            'Set rSubArea = Range("e" & rCurrentCell.Row, "g" & rCurrentCell.Row)  ' 需要填充分页小计公式的区域V列''B至V列的区域（共21列）
            r = rCurrentCell.Row
            Set rSubArea = Union(Range("e" & r), Range("f" & r), Range("g" & r)) ''填充分页小计公式的区域仅是其中3列（f、i、j)

            ' 使用 SUBTOTAL 公式的好处是方便扩展, 且不会对已计算区域重复计算(如果可能发生这种情况的话)
            rSubArea.Formula = "=SUBTOTAL(9," & "e2:" & .Offset(-1, 4).Address(1, 0) & ")"
            Set r1stSubCell = .Offset(1, 0)
        End With










    With Range("A" & Range("A65536").End(xlUp).Row + 1)
        .Value = "总  计"
        .Font.Bold = True
    End With
    'Set rSubArea = Range("e" & Range("A65536").End(xlUp).Row, "g" & Range("A65536").End(xlUp).Row) 'V列
    r = Range("A65536").End(xlUp).Row
    Set rSubArea = Union(Range("e" & r), Range("f" & r), Range("g" & r)) ''其中3列（f\i\j)
    rSubArea.Offset(0, 0) = "=SUBTOTAL(9," & "e2:e" & Range("A65536").End(xlUp).Row - 1 & ")"
   
    删除分页符
    ActiveWindow.View = xlNormalView
End Sub