本文于2023年5月30日首发于本人同名公众号，更多文章案例请搜索关注！
☆本期内容概要☆
VBA数组、字典
批量创建Excel文档
统一设置单元格格式
删除、添加图片
打印预览设置
大家好，我是冷水泡茶，昨天在EXCELHOME论坛上看到一个网友求助的贴子：
上面是他的需求、总表、分表。
我看了看，并不是很难，只是设置分表的格式要费点时间，类似的东西我帮别人做过一个。这次就不准备动手了，就发了个回复：
回到正题，说说我们的总表拆分的案例吧。
有这么一个集团公司，他的人力资源都在集团进行管理，所有员工的社保均在一张大表中进行处理，每个月需要把各个法人单位的明细表拆分出来，按照项目汇总，再设置统一格式，可以直接打印出来，供领导审批签字。
他的表格是这样的：
要求按照所属公司进行拆分，按照所属项目汇总，结果是这样的：
我们先看下效果：
下面我们简单理一下思路，跟我前面提到的帖子的回复差不多：
1、把总表数据按公司拆分，提取部分表头字段，按项目汇总，并且按照社保、公积、年金分别拆分。
2、每个公司三个文件（公司简称+社保、公积、年金）
3、每个文件中，按月份建立表格
4、统一设置表格的格式
5、加公司logo
接下来，我们看一下制作过程与部分代码：
1、插入一个userfrom，上面放上月份、类型选择的复合框控件
2、主程序拆分代码，mySplit
（1）用字典把公司、项目列表提取出来：
For g = 2 To iRow - 4 + 1 If arrSE(g, 3) <> "" And arrSE(g, 4) <> "" Then dGsKey = arrSE(g, 3) dXmKey = arrSE(g, 3) & "▲" & arrSE(g, 4) DicGs(dGsKey) = 1 '获取公司列表 DicXm(dXmKey) = 1 '获取项目列表（公司▲项目） End IfNext
（2）把每个公司的项目数量也提取出来：
'每个公司包括的项目数（在取得公司列表的时候也可以做，但要求公司、项目按顺序排列，中间不可以穿插其他公司、项目） For i = 0 To UBound(arrGs) For j = 0 To UBound(arrXm) If InStr(arrXm(j), arrGs(i) & "▲") > 0 Then arrXmS(i) = arrXmS(i) + 1 End If Next Next
（3）按项目进行汇总：
'按项目汇总 ReDim Preserve arrSum(1 To UBound(arrXm) + 1, 1 To UBound(arrSE, 2)) For i = 0 To UBound(arrXm) arrSum(i + 1, 4) = arrXm(i) arrSum(i + 1, 3) = Left(arrXm(i), InStr(arrXm(i), "▲") - 1) For j = 2 To UBound(arrSE, 1) If arrSE(j, 3) & "▲" & arrSE(j, 4) = arrXm(i) Then For s = 5 To UBound(arrSE, 2) - 1 If arrSum(i + 1, s) = "" Then arrSum(i + 1, s) = arrSE(j, s) Else arrSum(i + 1, s) = arrSum(i + 1, s) + arrSE(j, s) End If Next End If Next Next
（4）按公司建立文件：
For i = LBound(arrGs) To UBound(arrGs) '按公司建立文件 fleName = arrGs(i) & Left(iMonth, 4) & "年" & SplitType & "缴纳汇总表.xlsx" sPath = filePath & fleName sResult = Dir(sPath) If Len(sResult) = 0 Then '新建工作簿，每个公司保存一个文件 Set excelApp = CreateObject("Excel.Application") Set excelWB = excelApp.Workbooks.Add '新建文件的名称 excelWB.SaveAs filePath & fleName excelApp.Quit End If Next
（5）接着，循环公司列表，逐个公司提取数据。
（A）先判断文件有没有打开，打开了就激活它，没有打开就打开它：
For Each dstWB In Workbooks If dstWB.Name = fleName Then wbIsOpen = True dstWB.Activate Exit For End IfNextIf Not wbIsOpen Then Workbooks.Open Filename:=filePath & fleNameEnd If
（B）在公司文件中操作sheet表，如果当前月份的表不存在，就创建，否则就清除内容、图片。
If Not wbSheetExists(shtName) Then With ActiveWorkbook Set wksSht = .Worksheets.Add(after:=.Sheets(.Sheets.Count)) End With wksSht.Name = shtNameElse Sheets(shtName).Cells.Clear For Each sPic In ActiveSheet.Shapes sPic.Delete NextEnd If
（C）根据不同的拆分类型，写入表头信息：
If SplitType = "五险" Then ReDim arrTem(1 To lastRow, 1 To 12) TitlePos = Array(1, 4, 7, 9, 12, 14, 17, 19, 22) ActiveSheet.Cells(5, 3) = "养老保险" Sheets(shtName).Range(Cells(5, 3), Cells(5, 4)).Select With Selection .Merge Across:=False .HorizontalAlignment = xlHAlignCenter End With ActiveSheet.Cells(5, 5) = "医疗/生育保险" Sheets(shtName).Range(Cells(5, 5), Cells(5, 6)).Select With Selection .Merge Across:=False .HorizontalAlignment = xlHAlignCenter End With ActiveSheet.Cells(5, 7) = "失业保险" Sheets(shtName).Range(Cells(5, 7), Cells(5, 8)).Select With Selection .Merge Across:=False .HorizontalAlignment = xlHAlignCenter End With ActiveSheet.Cells(5, 9) = "工伤保险" ActiveSheet.Cells(5, 10) = "合计" Sheets(shtName).Range(Cells(5, 10), Cells(5, 11)).Select With Selection .Merge Across:=False .HorizontalAlignment = xlHAlignCenter End With ActiveSheet.Cells(5, 12) = "总计" Sheets(shtName).Range(Cells(5, 12), Cells(6, 12)).Select With Selection .Merge Across:=False .HorizontalAlignment = xlHAlignCenter End WithElseIf SplitType = "住房公积金" Then
（D）提取数据，存入数组arrTem()中，然后再一次性写入工作表：
For g = 1 To UBound(arrSum, 1) If arrSum(g, 3) = arrGs(i) Then arrTem(k, 1) = k arrTem(k, 2) = Right(arrSum(g, 4), Len(arrSum(g, 4)) - InStr(arrSum(g, 4), "▲")) For h = 2 To UBound(TitlePos) arrTem(k, h + 1) = arrSum(g, TitlePos(h)) Next If SplitType = "五险" Then arrTem(k, 10) = arrTem(k, 3) + arrTem(k, 5) + arrTem(k, 7) + arrTem(k, 9) arrTem(k, 11) = arrTem(k, 4) + arrTem(k, 6) + arrTem(k, 8) arrTem(k, 12) = arrTem(k, 10) + arrTem(k, 11) ElseIf SplitType = "住房公积金" Then arrTem(k, 5) = arrTem(k, 3) arrTem(k, 6) = arrTem(k, 4) arrTem(k, 7) = arrTem(k, 5) + arrTem(k, 6) ElseIf SplitType = "年金" Then arrTem(k, 5) = arrTem(k, 3) arrTem(k, 6) = arrTem(k, 4) arrTem(k, 7) = arrTem(k, 5) + arrTem(k, 6) End If For p = 3 To UBound(arrTem, 2) arrTem(lastRow, p) = arrTem(lastRow, p) + arrTem(k, p) Next k = k + 1 End IfNextiCol = UBound(arrTem, 2)'把结果填入表中Sheets(shtName).Range("A7").Resize(UBound(arrTem, 1), iCol) = arrTem
（E）再填写一些必要的信息，添加公司logo图片，设置表格格式：
Sheets(shtName).Range("A2") = arrGsqc(i)Sheets(shtName).Range(Cells(2, 1), Cells(2, iCol)).Select '大标题With Selection .Merge Across:=False .HorizontalAlignment = xlHAlignCenter .Font.Size = 18 .Font.Name = "宋体"End WithSheets(shtName).Range("A3") = Left(iMonth, 4) & "年" & Val(Right((iMonth), 2)) & "月" & SplitType & "缴纳汇总表"Sheets(shtName).Range(Cells(3, 1), Cells(3, iCol)).Select '副标题With Selection .Merge Across:=False .Font.Size = 14 .HorizontalAlignment = xlHAlignCenter .Font.Bold = TrueEnd WithSheets(shtName).Cells(4, iCol) = "单位:元"......'格式设置Sheets(shtName).Range(Cells(5, 1), Cells(lastRow + 6, iCol)).Select '表格划线With Selection.Borders .LineStyle = xlContinuous .ColorIndex = 1 .Weight = xlThinEnd WithWith Selection '.BorderAround xlContinuous, xlMedium, 1 .RowHeight = 24 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter '.WrapText = True '.Font.Name = "等线"End With......'添加LOGO图片ActiveSheet.Pictures.Insert(filePath & "logo.png").SelectWith Selection.ShapeRange .Left = 0 .Top = 0 .Height = 1.2 * 72 / 2.54 .Width = 4.93 * 72 / 2.54End WithRange("A2").SelectWith ActiveSheet.PageSetup .Zoom = False '.PrintArea = ActiveSheet.Range(Cells(1, 1), Cells(signRow, iCol - 1)) '//打印区域 .FitToPagesWide = 1 '//页宽是一页 .FitToPagesTall = False '//页高是 页 .PaperSize = xlPaperA4 '//纸张大小 .Orientation = xlLandscape '//横向打印 '.CenterFooter = "第 &P 页，共 &N 页" '.PrintTitleRows = "$4:$4"End With
（6）最后，打开文件夹：
'打开拆分文件所在目录Shell "explorer.exe " & ThisWorkbook.Path, vbMaximizedFocus
至此基本完结，其他一些按钮什么的就不说了，上面的示例代码仅为部分代码，感兴趣的朋友可以参看第二条文章。好，今天就到这吧，欢迎点赞、留言、分享，谢谢大家我们下期再会。
☆猜你喜欢☆
本文使用 文章同步助手 同步，本文于2023年5月30日首发于本人同名公众号，更多文章案例请搜索关注！