在HR工作中经常遇到需要把一个excel表拆分为多个的情况,比如考勤表分给各个部门核对,绩效奖金表发给各个分公司核对执行等等,涉及组织单元少的还好办,CV(Ctrl+C,Ctrl+V)大法即可,如果经常几十个单元的拆分恐怕手要残废了,下面给出一段我写的VBA,可以帮HR们解决这个问题,当然只要是相同问题,财务、办公室等等各个部门都可以使用,工具不选择用户^_^
使用方法如下:
1、打开你要拆分的excel文件,然后按Alt+F11组合键,调出VBA编辑环境
2、按照下图所示插入一个“模块”,点插入菜单,点选模块
3、双击上步操作生成的“模块1”,清空右边编辑区里面所有字符,把本文最下面代码区域的所有代码粘贴过去
4、注意根据自己的excel的情况修改一下设置
如下图,修改橙色字符即可
5、点击上图中橙色的“sheet1”位置(代码区域是没有颜色的,以上只是标注,目标是让光标在spliIt小程序的内部)
6、点击工具栏上的运行按钮(红色圈中的绿色三角),等待片刻就可以了。拆分好的excel和最初的文件在同一个位置保持。
如果还是看不懂,请来我们的学习成长群提问。加微信请备注VBA
'【代码区域,以下是代码】
'根据不同组织拆分附件,可以用于拆分绩效表、奖金表等等
Dim i, row_cnt, fgs, row_start, row_end, file_name
Dim wbk As Workbook
Dim wbk_data As Workbook
Dim wst, wst_data As Worksheet
Private Declare Function GetTickCount Lib "kernel32" () As Long
Function getFileName(branch)
'根据公司名称给出文件名
Select Case branch
Case Is = "安徽"
getFileName = "安徽-E902273-宋江"
Case Is = "北京"
getFileName = "北京-E202261-卢俊义"
Case Is = "常州"
getFileName = "常州-E802351-吴用"
Case Is = "大连"
getFileName = "大连-E900255-公孙胜"
Case Is = "福建"
getFileName = "福建-E200050-关胜"
Case Is = "甘肃"
getFileName = "甘肃-E502797-林冲 "
Case Is = "广东"
getFileName = "广东-E402868-秦明"
Case Is = "广西"
getFileName = "广西-E503109-呼延灼"
Case Is = "贵州"
getFileName = "贵州-E400390-花荣"
Case Is = "海南"
getFileName = "海南-E703813-柴进"
Case Is = "河北"
getFileName = "河北-E604680-李应"
Case Is = "河南"
getFileName = "河南-E504073-朱仝"
Case Is = "黑龙江"
getFileName = "黑龙江-E900943-鲁智深"
Case Is = "湖北"
getFileName = "湖北-E403456-武松"
Case Is = "湖南"
getFileName = "湖南-E703446-董平"
Case Is = "吉林"
getFileName = "吉林-E103921-张清"
Case Is = "江苏"
getFileName = "江苏-E904199-杨志"
Case Is = "江西"
getFileName = "江西-E003561-徐宁"
Case Is = "辽宁"
getFileName = "辽宁-E302911-索超"
Case Is = "内蒙古"
getFileName = "内蒙古-E701619-戴宗"
Case Is = "宁波"
getFileName = "宁波-E100353-刘唐"
Case Is = "宁夏"
getFileName = "宁夏-E900399-李逵"
Case Is = "青岛"
getFileName = "青岛-E300196-史进"
Case Is = "青海"
getFileName = "青海-E400777-穆弘"
Case Is = "厦门"
getFileName = "厦门-E803855-雷横"
Case Is = "山东"
getFileName = "山东-E502897-李俊"
Case Is = "山西"
getFileName = "山西-E001031-阮小二"
Case Is = "陕西"
getFileName = "陕西-E902286-张横"
Case Is = "上海"
getFileName = "上海-E501235-阮小五"
Case Is = "深圳"
getFileName = "深圳-E003586-张顺"
Case Is = "四川"
getFileName = "四川-E101790-阮小七"
Case Is = "苏州"
getFileName = "苏州-E904671-杨雄"
Case Is = "唐山"
getFileName = "唐山-E003975-石秀"
Case Is = "天津"
getFileName = "天津-E000756-解珍"
Case Is = "无锡"
getFileName = "无锡-E003586-解宝"
Case Is = "西藏"
getFileName = "西藏-E104067-燕青"
Case Is = "新疆"
getFileName = "新疆-E101650-朱武"
Case Is = "云南"
getFileName = "云南-E104033-黄信"
Case Is = "浙江"
getFileName = "浙江-E201193-孙立"
Case Is = "重庆"
getFileName = "重庆-E301217-宣赞"
Case Else
MsgBox ("未定义的数据:" & branch )
End Select
End Function
Sub splitIt()
Dim full_filename, last_fgs, file_path, last_time, col_fgs,ws
ws:="Sheet1" '表单的名称,注意:如不是Sheet1,需要修改
col_fgs = "A" '这里是分公司名字所在列,根据自己的需要修改
i = 2 '设置起始行,此行以上为表头,从此行开始是数据内容
'获取当前时间戳 ,用于统计时间
last_time = GetTickCount
'获取当前文件所在路径
file_path = Application.ActiveWorkbook.Path & "\"
'获取文件名(不含扩展名)
file_name = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) 'getFileName(Range("B2").Value)
'统计总行数
row_cnt = ActiveSheet.UsedRange.Rows.Count
ActiveWorkbook.Worksheets(ws).AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
(col_fgs & ":" & col_fgs), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(ws).AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
row_start = i
'todo 分公司名字列
last_fgs = Range(col_fgs & row_start).Value
Application.ScreenUpdating = False
Set wbk_data = ActiveWorkbook
While i < row_cnt + row_start
fgs = Range(col_fgs & i).Value
If fgs <> last_fgs Then
row_end = i - 1
'todo表头行,此程序的缺陷,暂未考虑多行表头
Rows("1").Select
Selection.Copy
Set wbk = Application.Workbooks.Add
wbk.Activate
ActiveSheet.Paste
wbk_data.Activate
Rows(row_start & ":" & row_end).Select
Application.CutCopyMode = False
Selection.Copy
wbk.Activate
'todo起始粘贴行
Range("A2").Select
ActiveSheet.Paste
Range("A2").Select
full_filename = file_path & file_name & "-" & getFileName(last_fgs) & ".xlsx"
wbk.SaveAs Filename:= _
full_filename, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wbk.Close
row_start = row_end + 1
End If
i = i + 1
last_fgs = fgs
DoEvents
Wend
Application.ScreenUpdating = True
MsgBox "耗时: " & Round((GetTickCount - last_time) / 1000) & "秒,处理完毕。"
End Sub
'【代码区域,以上是代码】
欢迎关注领悟学社:http://lingwu.tech