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