-
Excel VBA 总表拆分代码
☆本期内容概要☆
- 总表拆分代码
Private Sub mySplit()，拆分过程代码：包括数组、字典、批量创建与打开工作表、创建表页或清空表页内容、删除与插入图片、设置表格格式、打印预览页面设置、打开文件夹等。
Private Sub mySplit()
Dim arrSE() As Variant
Dim DicGs As Object, DicXm As Object, DicBm As Object, DicGsRenS As Object
Dim arrGs() As Variant, arrXm() As Variant, arrTem()
Dim arrSum()
Dim arrXmTotal(), arrXmS() 'arrXmS项目个数
Dim arrGsqc(), arrGsDzb()
Dim iMonth As String '月份
Dim iRow As Long, iCol As Long, tRow As Long, lastRow As Long
Dim rng As Range
Dim tm As Single
Dim SplitType As String
Dim wbIsOpen As Boolean
'tm = Timer
On Error Resume Next
Dim filePath As String
Dim crrWB As Workbook, dstWB As Workbook
Dim dGsKey, dXmKey
If Not ContinueProcedure() Then Exit Sub
Application.ScreenUpdating = False
Set crrWB = ThisWorkbook
filePath = ThisWorkbook.Path & "\"
iMonth = Me.CmbMonth
SplitType = Me.CmbType '拆分类型：社保、公积、年金
crrWB.Activate
Sheets(iMonth).Activate
iRow = ActiveSheet.UsedRange.Rows.Count
iCol = ActiveSheet.UsedRange.Columns.Count
arrSE = ActiveSheet.Range(Cells(4, 1), Cells(iRow, iCol)).Value '把社保表装入数组
Set DicGs = CreateObject("Scripting.Dictionary")
Set DicXm = CreateObject("Scripting.Dictionary")
Application.Calculation = xlManual '数据读取后，关闭自动重算，提高运行速度
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 If
Next
arrGs = DicGs.keys
arrXmS = DicGs.items
For i = 0 To UBound(arrXmS)
arrXmS(i) = 0
Next
arrXm = DicXm.keys
'每个公司包括的项目数（在取得公司列表的时候也可以做，但要求公司、项目按顺序排列，中间不可以穿插其他公司、项目）
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
'按项目汇总
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
'获取公司对照表
Sheets("对照表").Activate
Dim dRow, dCol
dRow = ActiveSheet.UsedRange.Rows.Count
'dCol = ActiveSheet.UsedRange.Columns.Count
arrGsDzb = Sheets("对照表").Range(Cells(1, 1), Cells(dRow, 2)).Value
arrGsqc = DicGs.keys
For i = 0 To UBound(arrGsqc)
For j = 1 To UBound(arrGsDzb, 1)
If arrGsDzb(j, 1) = arrGsqc(i) Then
arrGsqc(i) = arrGsDzb(j, 2)
End If
Next
Next
'按公司拆分
Dim signRow As Long
Dim TitlePos()
Dim sResult As String
Dim excelApp, excelWB As Object
Dim fleName As String
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
For i = LBound(arrGs) To UBound(arrGs)
'Stop
Dim sPic As Shape
Dim wksSht As Worksheet
Dim shtName As String
fleName = arrGs(i) & Left(iMonth, 4) & "年" & SplitType & "缴纳汇总表.xlsx"
shtName = arrGs(i) & iMonth
For Each dstWB In Workbooks
If dstWB.Name = fleName Then
wbIsOpen = True
dstWB.Activate
Exit For
End If
Next
If Not wbIsOpen Then
Workbooks.Open Filename:=filePath & fleName
End If
If Not wbSheetExists(shtName) Then
With ActiveWorkbook
Set wksSht = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
End With
wksSht.Name = shtName
Else
Sheets(shtName).Cells.Clear
For Each sPic In ActiveSheet.Shapes
sPic.Delete
Next
End If
Sheets(shtName).Activate
ActiveSheet.Cells(5, 1) = "序号"
Sheets(shtName).Range(Cells(5, 1), Cells(6, 1)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 2) = "利润中心"
Sheets(shtName).Range(Cells(5, 2), Cells(6, 2)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
tRow = arrXmS(i)
lastRow = tRow + 1
signRow = lastRow + 6 + 3
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
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 5) = "医疗/生育保险"
Sheets(shtName).Range(Cells(5, 5), Cells(5, 6)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 7) = "失业保险"
Sheets(shtName).Range(Cells(5, 7), Cells(5, 8)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.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
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 12) = "总计"
Sheets(shtName).Range(Cells(5, 12), Cells(6, 12)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ElseIf SplitType = "住房公积金" Then
ReDim arrTem(1 To lastRow, 1 To 7)
TitlePos = Array(1, 4, 24, 25)
ActiveSheet.Cells(5, 3) = SplitType
Sheets(shtName).Range(Cells(5, 3), Cells(5, 4)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 5) = "合计"
Sheets(shtName).Range(Cells(5, 5), Cells(5, 6)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 7) = "总计"
Sheets(shtName).Range(Cells(5, 7), Cells(6, 7)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ElseIf SplitType = "年金" Then
ReDim arrTem(1 To lastRow, 1 To 7)
TitlePos = Array(1, 4, 28, 29)
ActiveSheet.Cells(5, 3) = SplitType
Sheets(shtName).Range(Cells(5, 3), Cells(5, 4)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 5) = "合计"
Sheets(shtName).Range(Cells(5, 5), Cells(5, 6)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
ActiveSheet.Cells(5, 7) = "总计"
Sheets(shtName).Range(Cells(5, 7), Cells(6, 7)).Select
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
End If
k = 1
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 If
Next
iCol = UBound(arrTem, 2)
Sheets(shtName).Range("A7").Resize(UBound(arrTem, 1), iCol) = arrTem '把结果填入表中
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.Font.Name = "宋体"
Selection.Font.Size = 10
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 With
Sheets(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 = True
End With
Sheets(shtName).Cells(4, iCol) = "单位:元"
Sheets(shtName).Cells(4, 1) = "编制部门（盖章）：组织人事部（人力资源部）"
Sheets(shtName).Range(Cells(4, 1), Cells(4, 5)).Select
With Selection
.Merge Across:=False
.Font.Size = 12
.HorizontalAlignment = xlHAlignLeft
End With
Rows(1).RowHeight = 45
Rows(2).RowHeight = 45
Rows(3).RowHeight = 22
Rows(4).RowHeight = 20
ActiveSheet.Range(Cells(lastRow + 6, 1), Cells(lastRow + 6, 2)).Select '合计
With Selection
.Merge Across:=False
'.Font.Size = 12
.HorizontalAlignment = xlHAlignCenter
End With
Sheets(shtName).Cells(lastRow + 6, 1) = "合计"
Sheets(shtName).Range(Cells(signRow, 1), Cells(signRow, 2)).Select
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
End With
ActiveSheet.Range(Cells(5, 1), Cells(6, iCol)).Font.Bold = True
If SplitType = "五险" Then
ActiveSheet.Cells(6, 3) = "企业部分"
ActiveSheet.Cells(6, 5) = "企业部分"
ActiveSheet.Cells(6, 7) = "企业部分"
ActiveSheet.Cells(6, 9) = "企业部分"
ActiveSheet.Cells(6, 10) = "企业部分"
ActiveSheet.Cells(6, 4) = "个人部分"
ActiveSheet.Cells(6, 6) = "个人部分"
ActiveSheet.Cells(6, 8) = "个人部分"
ActiveSheet.Cells(6, 11) = "个人部分"
Sheets(shtName).Cells(signRow, 1).Value = "分管领导："
Sheets(shtName).Cells(signRow, 4).Value = "部门主任："
Sheets(shtName).Cells(signRow, 7).Value = "财务审核："
Sheets(shtName).Cells(signRow, 10).Value = "制表人："
Else
ActiveSheet.Cells(6, 3) = "企业部分"
ActiveSheet.Cells(6, 5) = "企业部分"
ActiveSheet.Cells(6, 4) = "个人部分"
ActiveSheet.Cells(6, 6) = "个人部分"
Sheets(shtName).Cells(signRow, 1).Value = "分管领导："
Sheets(shtName).Cells(signRow, 3).Value = "部门主任："
With Sheets(shtName).Range(Cells(signRow, 3), Cells(signRow, 4))
.Merge
.HorizontalAlignment = xlCenter
End With
Sheets(shtName).Cells(signRow, 5).Value = "财务审核："
Sheets(shtName).Cells(signRow, 5).HorizontalAlignment = xlRight
Sheets(shtName).Cells(signRow, 7).Value = "制表人："
End If
Rows(signRow).Font.Size = 12
Rows(signRow).Font.Bold = True
'格式设置
Sheets(shtName).Range(Cells(5, 1), Cells(lastRow + 6, iCol)).Select '表格划线
With Selection.Borders
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThin
End With
With Selection
'.BorderAround xlContinuous, xlMedium, 1
.RowHeight = 24
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'.WrapText = True
'.Font.Name = "等线"
End With
With Sheets(shtName).Range(Cells(7, 3), Cells(lastRow + 6, iCol))
.NumberFormatLocal = "#,##0.00_ ;[红色]-#,##0.00 "
'.Font.Name = "Georgia"
.HorizontalAlignment = xlCenter
If SplitType = "五险" Then
.ColumnWidth = 12.5
Else
.ColumnWidth = 20
End If
.RowHeight = 50
End With
Sheets(shtName).Range(Cells(7, 1), Cells(lastRow + 6, 1)).NumberFormatLocal = "G/通用格式" '序号格式为常规数字
Sheets(shtName).Range(Cells(7, 1), Cells(lastRow + 6, 1)).HorizontalAlignment = xlCenter
With Columns("A:B")
.EntireColumn.AutoFit
End With
'添加LOGO图片
ActiveSheet.Pictures.Insert(filePath & "logo.png").Select
With Selection.ShapeRange
.Left = 0
.Top = 0
.Height = 1.2 * 72 / 2.54
.Width = 4.93 * 72 / 2.54
End With
Range("A2").Select
With 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
ActiveWorkbook.Save
ActiveWorkbook.Close
Next
Unload UserForm1
Application.ScreenUpdating = True
MsgBox ("拆分完毕！")
Application.Calculation = xlAutomatic
'打开拆分文件所在目录
Shell "explorer.exe " & ThisWorkbook.Path, vbMaximizedFocus
End Sub
出处：https://zhuanlan.zhihu.com/p/652722393
栏目列表
最新更新
nodejs爬虫
Python正则表达式完全指南
爬取豆瓣Top250图书数据
shp 地图文件批量添加字段
爬虫小试牛刀（爬取学校通知公告）
【python基础】函数-初识函数
【python基础】函数-返回值
HTTP请求：requests模块基础使用必知必会
Python初学者友好丨详解参数传递类型
如何有效管理爬虫流量？
SQL SERVER中递归
2个场景实例讲解GaussDB(DWS)基表统计信息估
常用的 SQL Server 关键字及其含义
动手分析SQL Server中的事务中使用的锁
openGauss内核分析：SQL by pass & 经典执行
一招教你如何高效批量导入与更新数据
天天写SQL，这些神奇的特性你知道吗？
openGauss内核分析：执行计划生成
[IM002]Navicat ODBC驱动器管理器 未发现数据
初入Sql Server 之 存储过程的简单使用
这是目前我见过最好的跨域解决方案！
减少回流与重绘
减少回流与重绘
如何使用KrpanoToolJS在浏览器切图
performance.now() 与 Date.now() 对比
一款纯 JS 实现的轻量化图片编辑器
关于开发 VS Code 插件遇到的 workbench.scm.
前端设计模式——观察者模式
前端设计模式——中介者模式
创建型-原型模式