20170727xlVBA根据总名单和模板生成多页名单

Sub CountingDown()
    Dim Dic As Object    '用于分类统计
    Dim i As Long
    Dim CountDown As Long    '每页最多几条信息
    Dim x As Long, y As Long
    Dim Page As Long    '页数
    Dim Index As Long    '每页的序号
    Dim Sht As Worksheet
    Dim StartRow As Long, EndRow As Long    '分页的起始行

    Dim mRng As Range    '模板区域
    Set mRng = Sheets("受理模板").Range("A1:J26")    '保存模板区域行高与列宽

    With Sheets("总名单")
        Page = 0    '分页序号
        Index = 0    '姓名序号

        '开始划分第一页
        i = 2
        StartRow = 2
        CountDown = 36    '开始倒数信息条数
        Set Dic = CreateObject("Scripting.Dictionary")

        Do While .Cells(i, 1).Value <> ""    '循环连续非空行
            CountDown = CountDown - 1    '倒数-1

            Key = Trim(.Cells(i, 4).Text)    '获取分类
            If Len(Key) > 2 Then Key = "增驾"    '处理分类

            If Dic.Exists(Key) = False Then    '若是新增的分类
                Dic(Key) = 1    '开始计数
                CountDown = CountDown - 1    '分类统计需要占用一行
            Else
                Dic(Key) = Dic(Key) + 1    '如果不是新增的分类，分类计数
            End If

            If CountDown = 0 Or .Cells(i + 1, 1).Value = "" Then    '若满一页，或者结束
                Page = Page + 1    '新增一页
                NewName = "受理名单" & Page    '获取新表名
                CopyModel NewName    '新增名单表
                Set Sht = Sheets(NewName)

                EndRow = i    '保存结束行

                '初始化 每一页的行列号
                x = 0
                y = 1
                'Index = 0  '改为从一开始算
                '内循环
                For Each k In Dic.keys    '循环每个类别
                    For n = StartRow To EndRow    '循环刚统计的每个人
                        '处理类别
                        Key = Trim(.Cells(n, 4).Text)
                        If Len(Key) > 2 Then Key = "增驾"

                        '如果类别符合，则输出
                        If Key = k Then
                            '每满18行，换列
                            If x = 18 Then
                                x = 0
                                y = 6
                            End If

                            '累计序号
                            Index = Index + 1

                            '累计信息序号（包括分类）
                            x = x + 1

                            '输出相应的信息
                            Sht.Cells(3 + x, y).Value = Index
                            Sht.Cells(3 + x, y + 1).Value = .Cells(n, 1).Value
                            Sht.Cells(3 + x, y + 2).Value = "'" & .Cells(n, 2).Value

                        End If
                    Next n

                    '每满18行，换列
                    If x = 18 Then
                        x = 0
                        y = 6
                    End If
                    x = x + 1
                    '输出分类统计结果
                    Sht.Cells(3 + x, y + 2).Value = k & Dic(k) & "人"

                Next k

                '保持模板行高
                For x = 1 To 26
                    Sht.Rows(1).RowHeight = mRng.Rows(x).RowHeight
                Next x
                For y = 1 To 10
                    Sht.Columns(y).ColumnWidth = mRng.Columns(y).ColumnWidth
                Next y

                '开始下一页
                StartRow = EndRow + 1
                CountDown = 36
                Set Dic = CreateObject("Scripting.Dictionary")
            End If

            i = i + 1
        Loop
    End With

    Set Sht = Nothing
    Set Dic = Nothing

End Sub
Sub CopyModel(ByVal NewName As String)
    Dim mSht As Worksheet
    Dim NewSht As Worksheet
    Set mSht = Sheets("受理模板")
    mSht.Copy After:=Sheets(Sheets.Count)
    Set NewSht = Sheets(Sheets.Count)
    On Error Resume Next
    Sheets(NewName).Delete
    On Error GoTo 0
    NewSht.Name = NewName
End Sub