Excel VBA 按项目把总表拆分表明细表真实案例

本文首发于2023年5月30日于我的同名公众号，其他文章请搜索关注！

☆本期总结☆

VBA数组、字典

批量创建Excel文档

统一设置单元格格式

删除和添加图像

打印预览设置

大家好，我用冷水泡茶。昨天在EXCELHOME论坛上看到一位网友求助的帖子：

以上是要求、总列表和子列表。

我查了一下，发现并不难，只是设置分表格式花了一些时间。我也为其他人做过类似的事情。这次我不打算采取行动，所以我发了一条回复：

回到主题，我们来谈谈我们的主列表拆分的情况。

有集团公司，他们的人力资源是在集团内部管理的，所有员工的社保都是在大表里处理的。每个月，需要对每个法人单位的明细表进行细分，按照项目进行汇总，然后确定统一的格式，并可以直接打印，供管理层审批和签字。

它看起来像这样：

需要按照拥有的公司进行细分，按照拥有的项目进行汇总。结果如下：

我们先看一下效果：

下面简单理清一下思路，这个思路和我之前提到的帖子的回复类似：

1、按公司拆分总表数据，提取多个表头字段，按项目汇总，按社保、公积金、年金划分。

2、每个公司三份文件（公司叫社保、储蓄基金、年金）

3在每个文件中，按月份创建一个表

4统一表格格式

5添加公司标志

接下来我们看一下制作流程和一些代码：

1输入usersfrom，使用月份的合并框控件并在其上键入一个选项。

2主程序分割代码，mySplit

(1)使用字典提取公司和项目列表：

Forg2ToiRow-41IfarrSE(g,3)''AndarrSE(g,4)''ThendGsKeyarrSE(g,3)dXmKeyarrSE(g,3)'▲'arrSE(g,4)DicGs(dGsKey)1'获取公司列表DicXm(dXmKey)1'获取项目列表(公司▲项目)EndIfNext

（2）提取各公司的项目数量：

'每个公司包含的项目数量（获取公司列表时也可以做，但公司和项目必须按顺序排列，不能穿插其他公司和项目）Fori0ToUBound(arrGs)Forj0ToUBound(arrXm)IfInStr(arrXm(j),arrGs(i)'▲')>0ThenarrXmS(i)arrXmS(i)1EndIfNextNext

（三）按项目汇总：

'基于projectReDimPreservearrSum(1ToUBound(arrXm)1,1ToUBound(arrSE,2))Fori0ToUBound(arrXm)arrSum(i1,4)arrXm(i)arrSum(i1,3)Left(arrXm(i),InStr(arrXm()的摘要i),'▲')-1)Forj2ToUBound(arrSE,1)IfarrSE(j,3)'▲'arrSE(j,4)arrXm(i)ThenFors5ToUBound(arrSE,2)-1IfarrSum(i1,s)''ThenarrSum(i1,s)arrSE(j,s)ElsearrSum(i1,s)arrSum(i1,s)arrSE(j,s)EndIfNextEndIfNextNext

(4)按公司创建档案：

ForiLBound(arrGs)ToUBound(arrGs)'按公司创建文件fleNamearrGs(i)Left(iMonth,4)'年'SplitType'付款汇总表xlsx'PathfilePathfleNamesResultDir(sPath)IfLen(sResult)0Then'新建工作簿，分别为各公司保存文件SetexcelAppCreateObject('ExcelApplication')SetexcelWBexcelAppWorkbooksAdd'新文件名excelWBSaveAsfilePathfleNameexcelAppQuitEndIfNext

(5)然后，浏览公司列表并一一提取数据。

(A)首先判断文件是否打开，如果打开则启用，如果未打开则打开：

对于每个WBInWorkbooksIfdstWBNamefleNameThenwbIsOpenTruedstWBActivateExitForEndIfNextIfNotwbIsOpenThenWorkbooksOpenFilename:filePathfleNameEndIf

(B)公司档案中的操作表。如果本月的工作表不存在，请创建一个。

IfNotwbSheetExists(shtName)ThenWithActiveWorkbookSetwksShtWorksheetsAdd(after:Sheets(SheetsCount))EndWithwksShtNameshtNameElseSheets(shtName)CellsClearForEachsPicInActiveSheetShapessPicDeleteNextEndIf

(C)根据不同的分割类型写入头信息：

IfSplitType'五险'ThenReDimarrTem(1TolastRow,1To12)TitlePosArray(1,4,7,9,12,14,17,19,22)ActiveSheetCells(5,3)'退休险'Sheets(shtName)Range(Cells(5,3),Cells(5,4))SelectWithSelectionMergeAcross:FalseHorizo??ntalAlignmentxlHAlignCenterEndWithActiveSheetCells(5,5)'工作表'健康/生育保险'(shtName)Range(Cells(5,5),Cells(5,6))SelectWithSelectionMergeAcross:FalseHorizo??ntalAlignmentxlHAlignCenterEndWithActiveSheetCells(5,7)'Sheets失业保险(shtName)Range(Cells(5,7),Cells(5,8))SelectWithSelectionMergeAcross:FalseHorizo??ntalAlignmentxlHAlignCenterEndWithActiveSheetCells(5,9)'工伤保险'ActiveSheetCells(5,10)'合计'Sheets(shtName)Range(Cells(5,10),Cells(5,11))SelectWithSelectionMergeacross:falsehorizo??ntalAntignmentxlhalignCenterendWithActiveSheet然后

(D)提取数据，将其存储在arrTem()数组中，然后立即将其写入工作表：

Forg1ToUBound(arrSum,1)IfarrSum(g,3)arrGs(i)ThenarrTem(k,1)karrTem(k,2)Right(arrSum(g,4),Len(arrSum(g,4))-InStr(arrSum)(g,4),'▲'))Forh2ToUBound(TitlePos)arrTem(k,h1)arrSum(g,TitlePos(h))NextIfSplitType'五风险'ThenarrTem(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)ElseIfSplitType'住房公积金'ThenarrTem(k,5)arrTem(k,3)arrTem(k,6)arrTem(k,4)arrTem(k,7)arrTem(k,5)arrTem(k,6)ElseIfSplitType'年金'ThenarrTem(k,5)arrTem(k,3)arrTem(k,6)arrTem(k,4)arrTem(k,7)arrTem(k,5)arrTem(k,6)EndIfForp3ToUBound(arrTem,2)arrTem(lastRow,p)arrTem(lastRow,p)arrTem(k,p)Nextkk1EndIfNextiColUBound(arrTem,2)'将结果填充到表格Sheets(shtName)Range('A7')Resize(UBound(arrTem,1)),iCol)arrTem

(E)填写一些必填信息，添加公司标志图片，并设置表格格式：

Sheets(shtName)Range('A2')arrGsqc(i)Sheets(shtName)Range(Cells(2,1),Cells(2,iCol))Select'BigTitleWithSelectionMergeAcross:FalseHorizo??ntalAlignmentxlHAlignCenterFont。Size18FontName'宋体'EndWithSheets(shtName)Range('A3')Left(iMonth,4)'年'Val(Right((iMonth),2))'月'SplitType'付款汇总表'表格(shtName)Range(Cells(3,1),Cells(3,iCol))Select'SubtitleWithSelectionMergeAcross:FalseFontSize14Horizo??ntalAlignmentxlHAlignCenterFontBoldTrueEndWithSheets(shtName)Cells(4,iCol)'单位：元''Sheets(shtName)格式设置Range(Cells(5,1),Cells(lastRow6,iCol))Select'表格行WithSelectionBordersLineStylexlContinouslyColorIndex1WeightxlThinEndWithWithSelection'BorderAroundxlContinously,xlMedium,1RowHeight24Horizo??ntalAlignmentxlCenterVerticalAlignmentxlCenter'WrapTextTrue'FontName'etc'EndWith'添加图片LOGOActiveSheetPicturesInsert(filePath'logopng')SelectWithSelectionShapeRangeLeft0Top0Height1。2*72/254Width493*72/254EndWithRange('A2')SelectWithActiveSheetPageSetupZoomFalse'PrintAreaActiveSheetRange(Sel(1,1),Sel(signRow,iCol-1))'//打印区域FitToPagesWide1'//页面宽度为一页FitToPagesTallFalse'//页面高度为一页PaperSizexlPaperA4'//纸张尺寸OrientationxlLandscape'//水平打印'CenterFooter'P页，共N页''PrintTitleRows'$4:$4'结尾为

(6)最后打开文件夹：

'打开分割文件所在目录Shell'explorerexe'ThisWorkbookPath,vbMaximizedFocuS

到这里就基本完成了，其他的按钮就不说了。上面的代码示例只是其中的一部分。有兴趣的朋友可以参考第二篇文章。好啦，今天就讲到这里。欢迎点赞、评论和分享。谢谢大家，下次再见。

☆你可能会喜欢☆

本文是使用文章同步助手同步的。本文首发于2023年5月30日于我的同名公众号，其他文章请搜索关注！