HR小技巧:拆分表格

HR小技巧:拆分表格_第1张图片

在HR工作中经常遇到需要把一个excel表拆分为多个的情况,比如考勤表分给各个部门核对,绩效奖金表发给各个分公司核对执行等等,涉及组织单元少的还好办,CV(Ctrl+C,Ctrl+V)大法即可,如果经常几十个单元的拆分恐怕手要残废了,下面给出一段我写的VBA,可以帮HR们解决这个问题,当然只要是相同问题,财务、办公室等等各个部门都可以使用,工具不选择用户^_^

使用方法如下:

1、打开你要拆分的excel文件,然后按Alt+F11组合键,调出VBA编辑环境

2、按照下图所示插入一个“模块”,点插入菜单,点选模块

HR小技巧:拆分表格_第2张图片

3、双击上步操作生成的“模块1”,清空右边编辑区里面所有字符,把本文最下面代码区域的所有代码粘贴过去

HR小技巧:拆分表格_第3张图片

4、注意根据自己的excel的情况修改一下设置

如下图,修改橙色字符即可

HR小技巧:拆分表格_第4张图片

5、点击上图中橙色的“sheet1”位置(代码区域是没有颜色的,以上只是标注,目标是让光标在spliIt小程序的内部)

6、点击工具栏上的运行按钮(红色圈中的绿色三角),等待片刻就可以了。拆分好的excel和最初的文件在同一个位置保持。

HR小技巧:拆分表格_第5张图片

如果还是看不懂,请来我们的学习成长群提问。加微信请备注VBA

HR小技巧:拆分表格_第6张图片

'【代码区域,以下是代码】

'根据不同组织拆分附件,可以用于拆分绩效表、奖金表等等

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

你可能感兴趣的:(HR小技巧:拆分表格)