自动分页小计、总计增加分类合计功能

hanzhang98

自动分页小计、分类合计、总计问题求助：
       本VBA菜鸟，在论坛找的示例代码，已按照示例实现“分页小计”和“总计”功能。现在想要达到的效果是：   
       1、按“岗位类别”（B列）进行按类“分页小计”和“岗类合计”，即：增加类似“B列单元格值 + 合计”的内容；
       2、如果“岗位类别”（B列）的人数小于一页的，加入“本页小计”和“B列单元格值+合计”二行。如果“岗位类别”（B列）的人数大于一页的，在每页加入“本页小计”，在该“岗位类别”最后一页要加入“本页小计”和“B列单元格值+合计”二行，且该页不再显示B列接下来的另一类“岗位类别”的人员，即将B列接下来的另一类“岗位类别”的人员推到下一页再显示；
       3、在所有类别的最后一页加入“总计”行。
       请各位大神帮助添加修改代码。谢谢！
       想要达到的效果请参看附件里的 “想达到的效果”工作表的效果样式。   

hanzhang98

1. 附件怎么传不上来。

复制代码

hanzhang98

附件怎么传不上去，先添加代码如下。

1. Dim rCurrentCell As Range   ' 每一页之分页小计所在单元格
   
2. Dim r1stSubCell As Range    ' 小计区域第一个单元格
   
3. ' -------------------------------------------------
   
4. ' 从这里开始执行
   
5. Sub Main()
   
6.     t = Timer
   
7.     Application.ScreenUpdating = False         '关闭屏幕刷新
   
8.     Worksheets("sheet1").Activate              '激活工作表“sheet1”
   
9.     删除分页符
   
10.     Set r1stSubCell = Range("A5")           ' 本例名单从 A5 单元格开始
    
11. 
    
12.     For Each rCurrentCell In Range(r1stSubCell, r1stSubCell.End(xlDown))
    
13.         If rCurrentCell = "本页小计" Or rCurrentCell = "总  计" Then rCurrentCell.EntireRow.Delete
    
14.     Next
    
15.     Set r1stSubCell = Range("A5")           ' 本例名单从 A5 单元格开始
    
16.     For Each rCurrentCell In Range(r1stSubCell, r1stSubCell.End(xlDown))
    
17.         If rCurrentCell = "本页小计" Or rCurrentCell = "总  计" Then rCurrentCell.EntireRow.Delete
    
18.     Next
    
19. 
    
20.     新建分页小计
    
21.     Range("A5").Activate
    
22. 
    
23.     MsgBox "分页小计已完成!" & Chr(13) & "共用时间" & Round(Timer - t, 2) & "秒"
    
24.     Application.ScreenUpdating = True         '开启屏幕刷新
    
25. End Sub
    
26. ' -------------------------------------------------
    
27. Sub 删除原有的分页小计行()
    
28.     Application.ScreenUpdating = False         '关闭屏幕刷新
    
29.     Set r1stSubCell = Range("A5")              '本例名单从 A5 单元格开始
    
30.     For Each rCurrentCell In Range(r1stSubCell, r1stSubCell.End(xlDown))
    
31.         If rCurrentCell = "本页小计" Or rCurrentCell = "总  计" Then rCurrentCell.EntireRow.Delete
    
32.     Next
    
33.     Set r1stSubCell = Range("A5")           ' 本例名单从 A5 单元格开始
    
34.     For Each rCurrentCell In Range(r1stSubCell, r1stSubCell.End(xlDown))
    
35.         If rCurrentCell = "本页小计" Or rCurrentCell = "总  计" Then rCurrentCell.EntireRow.Delete
    
36.     Next
    
37. 
    
38.     Range("A1").Activate
    
39.     MsgBox "已成功删除分页小计"
    
40.     Application.ScreenUpdating = True         '开启屏幕刷新
    
41. End Sub
    
42. Sub 新建分页小计()
    
43.     Dim iSubCol As Integer, rSubArea As Range
    
44.     Dim hb As HPageBreak
    
45. 
    
46.     Worksheets("sheet1").Activate              '激活工作表“sheet1”
    
47.     Rows(Range("a65536").End(xlUp).Row).Copy Range("a" & Range("a65536").End(xlUp).Row + 1)
    
48.     Rows(Range("a65536").End(xlUp).Row).ClearContents
    
49.     Range("a" & Range("a65536").End(xlUp).Row + 1) = " "
    
50.     ActiveWindow.View = xlPageBreakPreview  ' 进入 分页浏览 模式, 以便 EXCEL 正确计页
    
51.     Set r1stSubCell = Range("A5")           ' 本例名单从 A5 单元格开始
    
52.     iSubCol = 9                             ' 本例小计项共有 21 列
    
53. 
    
54.     ' 最后一行插入手工分页符
    
55.     ActiveSheet.HPageBreaks.Add Before:=r1stSubCell.End(xlDown).Offset(1, 0)
    
56.     ActiveSheet.HPageBreaks.Add Before:=Range("a65536").End(xlUp)
    
57. 
    
58.     ' 测试每一个分页符,
    
59.     ' 如果是自动分页符, 则在其上一行插入一小计行, 而本行纳入下一页
    
60.     ' 否则, 在本行插入一小计行
    
61.     For Each hb In ActiveSheet.HPageBreaks
    
62.         Set rCurrentCell = hb.Location
    
63.         rCurrentCell.Select                 ' 看看先
    
64. 
    
65.         If hb.Type = xlPageBreakAutomatic Then Set rCurrentCell = rCurrentCell.Offset(-1, 0)
    
66. 
    
67.         rCurrentCell.EntireRow.Insert
    
68.         Set rCurrentCell = rCurrentCell.Offset(-1, 0)
    
69. 
    
70.         ' 添加分页小计内容
    
71.         With rCurrentCell
    
72.             .Value = "本页小计"
    
73.             .Font.Bold = True
    
74. 
    
75.             'Set rSubArea = Application.Union(Range("d" & rCurrentCell.Row), Range("V" & rCurrentCell.Row))  ' 需要填充分页小计公式的区域V列
    
76. 
    
77.             'Set rSubArea = Range("b" & rCurrentCell.Row, "V" & rCurrentCell.Row)  ' 需要填充分页小计公式的区域V列''B至V列的区域（共21列）
    
78.             r = rCurrentCell.Row
    
79.             Set rSubArea = Union(Range("d" & r), Range("f" & r), Range("j" & r), Range("m" & r)) ''填充分页小计公式的区域仅是其中3列（f、i、j)
    
80. 
    
81.             ' 使用 SUBTOTAL 公式的好处是方便扩展, 且不会对已计算区域重复计算(如果可能发生这种情况的话)
    
82.             rSubArea.Formula = "=SUBTOTAL(9," & r1stSubCell.Offset(0, 5).Address(1, 0) & ":" & .Offset(-1, 5).Address(1, 0) & ")"
    
83.             Set r1stSubCell = .Offset(1, 0)
    
84.         End With
    
85.     Next
    
86.     Rows(Range("a65536").End(xlUp).Row).Clear
    
87. 
    
88.     If Range("A65536").End(xlUp) = " " Then Rows(Range("a65536").End(xlUp).Row).Clear
    
89. 
    
90.     Rows(Range("a65536").End(xlUp).Row).Copy Range("a" & Range("a65536").End(xlUp).Row + 1)
    
91.     Rows(Range("a65536").End(xlUp).Row).ClearContents
    
92. 
    
93.     With Range("A" & Range("A65536").End(xlUp).Row + 1)
    
94.         .Value = "总  计"
    
95.         .Font.Bold = True
    
96.     End With
    
97.     'Set rSubArea = Range("b" & Range("A65536").End(xlUp).Row, "V" & Range("A65536").End(xlUp).Row) 'V列
    
98.     r = Range("A65536").End(xlUp).Row
    
99.     Set rSubArea = Union(Range("d" & r), Range("f" & r), Range("j" & r), Range("m" & r)) ''其中3列（f\i\j)
    
100.     rSubArea.Offset(0, 0) = "=SUBTOTAL(9," & "f5:f" & Range("A65536").End(xlUp).Row - 1 & ")"
     
101.     删除分页符
     
102.     ActiveWindow.View = xlNormalView
     
103. End Sub
     
104. Sub 删除分页符()
     
105. On Error Resume Next
     
106.     t = ActiveSheet.HPageBreaks.Count
     
107.     For n = t To 1 Step -1
     
108.         If ActiveSheet.HPageBreaks(n).Extent = xlPageBreakFull Then
     
109.             ActiveSheet.HPageBreaks(n).Delete
     
110.         End If
     
111.         t = ActiveSheet.HPageBreaks.Count
     
112.     Next
     
113. End Sub
     
114. 
     

复制代码