20170727xlVBA根据总名单和模板生成多页名单
Posted Excel VBA 小天地
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了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
以上是关于20170727xlVBA根据总名单和模板生成多页名单的主要内容,如果未能解决你的问题,请参考以下文章