人事资料管理
来源:互联网 发布:淘宝怎么没有换货申请 编辑:程序博客网 时间:2024/04/19 01:17
人事资料管理
此段文字节选自《Excel VBA范例大全》一书
专业的密码登录界面;
公司简介及程序说明;
用窗体录入员工资料;
身份证号及工号重复提示;
厂牌打印;
工资表计算、年资计算、个人所得税计算;
制作工资条;
随意透视各部门工资。
(1)建立工作簿架构
=LOOKUP(MONTH(TODAY())-MONTH(G3)+(YEAR(TODAY())-YEAR(G3))*12,{0,6,12,24,36,48,60},{0,50,100,150,200,250,300})
=INT(SUM((I3-1600>{0,500,2000,5000,20000,40000,60000,80000,100000})*(I3-1600
=-{0,500,2000,5000,20000,40000,60000,80000,100000}))*0.05)
此公式为数组公式,输入完毕后需要同时按Ctrl+Shift+Enter组合键完成。
(2)设计登录窗体
(3)设计资料录入主界面
登录框权限验证;
网页滚动式公司简介,支持鼠标移过事件;
通过窗体录入数据;
检测录入资料的重复性并提示;
文本框的自动定位:包括每录完一笔资料时定位第一个录入框,以及某项目出现重复错误时光标自动定位于该项录入框中;
有制作和删除工资条专用菜单;
控制菜单的可用性:在指定页面中可操作,否则菜单呈灰色禁用状态。
(1)系统初始化及生成菜单代码
① 初始化代码,存于ThisWorkbook代码窗口中(用于建立与控制菜单、显示登录框):
Private Sub Workbook_Open() '开启工作簿时发生
Application.EnableCancelKey = xlDisabled '禁止中断执行
Application.Visible = False '程序不可见
生成工资条菜单 '生成菜单
登录.Show '菜单登录框
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.Visible = True '关闭工作簿时程序可见
Application.CommandBars(1).Controls("工资条专用(&P)").Delete '删除菜单
Application.EnableCancelKey = xlInterrupt '恢复中断模式
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object) '激活工作表时发生此事件
Dim i As Byte
For i = 1 To 3 '如果当前表是“工资表”,则前三个子菜单可见,否则不可见
Application.CommandBars(1).Controls("工资条专用(&P)")
.Controls(i).Enabled = (ActiveSheet.Name = "工资表")
Next i
End Sub
② 生成菜单及子菜单所对应的程序:
Sub 生成工资条菜单()
Dim Menu As CommandBarControl, SubMenu As CommandBarControl
Set SubMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, 1, , 8, 1)
'生成一个下拉菜单
SubMenu.Caption = "工资条专用(&P)"
With SubMenu.Controls.Add(msoControlButton, 1, , , True) '生成子菜单
.Caption = "生成工资条(&C)"
.OnAction = "生成工资条"
.Style = msoButtonIconAndCaption
.FaceId = 137
End With
With SubMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "删除工资条(&D)"
.OnAction = "删除工资条"
.Style = msoButtonIconAndCaption
.FaceId = 138
End With
With SubMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "按部门透视工资表(&A)"
.OnAction = "建立透视表"
.Style = msoButtonIconAndCaption
.FaceId = 481
End With
With SubMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "返回资料输入窗口(&R)"
.OnAction = "返回窗体"
.Style = msoButtonIconAndCaption
.FaceId = 484
End With
End Sub
Sub 生成工资条()
Application.ScreenUpdating = False
Dim cell As Range, YRng As Range, Xrng As Range, RowNum As Integer, i As Integer
If ActiveSheet.ProtectContents Then MsgBox "工作表已保护,本程序拒绝执
行!", 64, "提示": Exit Sub '如果保存了工作表则不执行程序
Set cell = Cells(3, 2) '设定变量为C2单元格
Do '开始循环
cell.Offset(1, 0).Rows("1:3").EntireRow.Insert Shift:=xlDown
'在单元格后插入三行
Set cell = cell.End(xlDown)
'重新设定变量cell的地址:当前单元格向下第一个非空单元格
RowNum = ActiveSheet.UsedRange.Rows.Count '记录当前表已用区域行数
Loop While cell.Row < RowNum
'程序循环执行直到当前单元格向下第一个非空单元格的行号大于当前表已用区域行数
RowNum = ActiveSheet.UsedRange.Rows.Count '记录当前表已用区域行数
Rows("1:2").Select '选择两行标题行
Selection.Copy '复制标题行
Set YRng = Rows("5:6")
For i = 9 To RowNum Step 4
Set YRng = Union(YRng, Rows(i & ":" & i + 1)) '组合需要复制标题的行
Next
YRng.Select '选中该区域
ActiveSheet.Paste '粘贴
Set Xrng = Rows(4)
For i = 8 To RowNum Step 4
Set Xrng = Union(Xrng, Rows(i)) '组合所有空行
Next
Xrng.Select '选择空行
Selection.Borders.LineStyle = xlNone '去除空行的网格线
Application.ScreenUpdating = True
End Sub
Sub 删除工资条()
Dim cell As Range, RowNum As Integer, i As Integer, down
Set cell = Rows("4:6")
RowNum = Range("B1048576").End(xlUp).Row '记录B列最后一个非空行的行号
For i = 8 To RowNum Step 4
Set cell = Union(cell, Range("B" & i).Rows("1:3").EntireRow)
'组合标题行及空行(不包括第一个标题行)
Next
Application.ScreenUpdating = False
cell.Select '选择区域
Selection.Delete Shift:=xlUp '删除
Application.ScreenUpdating = True
End Sub
Sub 建立透视表()
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=
Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.UsedRange
.Offset(1, 1))) .CreatePivotTable TableDestination:="",
TableName:="按部门查看" '选择数据源
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(1, 1)
'透视表存放位置
With ActiveSheet.PivotTables("按部门查看").PivotFields("姓名")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("按部门查看").PivotFields("部门")
.Orientation = xlPageField
.Position = 1
End With
ActiveSheet.PivotTables("按部门查看").AddDataField ActiveSheet.PivotTables
("按部门查看").PivotFields("工资"), "求和项:工资", xlSum
ActiveSheet.Move after:=Sheets(Sheets.Count)
ActiveSheet.Name = "透视工资表"
End Sub
Sub 返回窗体()
Application.Visible = False
人事资料.Show
End Sub
(2)登录框代码
Private Sub CommandButton1_Click()
Static i '声明一个非静态变量
If TextBox1.Text = "" Then MsgBox "用户名不能为空!": Exit Sub
'未输入用户名则退出程序
If i = 3 Then '如果错误三次
MsgBox "你已尝试三次错误,程序即将关闭!" '提示
Unload Me '关闭窗体
Application.Visible = True '恢复程序可见
ThisWorkbook.Close False '关闭工作簿且不保存
Exit Sub '退出程序
End If
'只能andy/sky/andysky三个指定用户名可以登录
If (TextBox1.Text = "andy" Or TextBox1.Text = "sky" Or TextBox1.Text=
"andysky") And TextBox1.Text <> "" Then
If TextBox2.Text <> "admin" Then '如果密码不是admin
MsgBox "密码不符,请重新输入!" '提示
i = i + 1 '累加变量,记录错误次数
Exit Sub '退出程序
Else '否则
i = 0 '恢复计数器为0
Unload Me '关闭窗体
MsgBox TextBox1.Text & ":你好" & Chr(10) & "欢迎进入系统!",
vbOKOnly, "登录成功" '问候
人事资料.Show '显示资料录入窗体
End If
Else
MsgBox "用户名不符,请重新输入!", 64, "警告" '用户名不对则退出
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode <> 1 Then Cancel = True '不允许关闭窗体
End Sub
(3)资料录入窗体代码
① 滚动的公司简介代码如下(鼠标移过时文字将停止滚动):
Const Wt1 = " document.write ("""
Const Wt2 = """)"
Const D1 = "<p style='line-height: 150%; margin-top: 0; margin-bottom: 0'>"
Private Sub UserForm_Activate()
Me.MultiPage1.Value = 0
WebBrowser1.Navigate "about:blank" '初始化空白网页
With Me.ShockwaveFlash1 '调整Flash长宽高
.Height = 54
.Width = 414
.Top = 252
End With
Do While WebBrowser1.Busy
DoEvents
Loop
With Me.WebBrowser1.Document
.Open
.WriteLn "<style TYPE=" & Chr(34) & "text/css" & Chr(34) & ">"
.WriteLn "<!--"
.WriteLn "A:link{text-decoration:none}"
.WriteLn "A:visited{text-decoration:none}"
.WriteLn "A:hover {color: #00FF00;text-decoration:underline}"
.WriteLn "body {background-color: #3399FF}" '设置背景色
.WriteLn "-->"
.WriteLn "</style>"
.WriteLn "<BODY scroll=" & VBA.Chr(34) & "no" & VBA.Chr(34) & _
"onselectstart=event.returnValue=false " & _
"oncontextmenu=window.event.returnValue=false " & _
">"
.WriteLn "<content=" & Chr(34) & "text/html; charset=big5" & Chr(34) & ">"
.WriteLn "<TABLE cellSpacing=0 cellPadding=0 border=0>"
.WriteLn "<SCRIPT language=JavaScript>"
'以下设置文字滚动速度和方向及宽度/高度,help.stop表示鼠标移过时停止滚动
.WriteLn Wt1 & "<marquee scrollamount='1' scrolldelay='30' direction=
'UP' width='250' id='help' height='300' onmouseover='help.stop()'
onmouseout='help.start()'>" & Chr(34) & ")"
.WriteLn Wt1 & "<Font style='filter:glow(color=##FF8000,
strength=2); height: 1px; padding: 1px'>" & Wt2
'以下是网页正文
.WriteLn Wt1 & "设计者:<a href='mailto:andy_qc@163.com'
target='_blank'>罗刚君 andysky</a> " & Wt2
.WriteLn Wt1 & "<P></P>" & Wt2
.WriteLn Wt1 & "</font>" & Wt2
.WriteLn Wt1 & "<Font Size=3>" & Wt2
.WriteLn Wt1 & "<Br color=#00FF00 >" & Wt2
.WriteLn Wt1 & "<HR>" & "<P></P>" & Wt2
.WriteLn Wt1 & "四维公司简介" & "<P></P>" & Wt2
.WriteLn Wt1 & "四维实业公司成立于1988年" & "<P></P>" & Wt2
.WriteLn Wt1 & "由董事长罗四维注册建厂" & "<P></P>" & Wt2
.WriteLn Wt1 & "公司拥有厂房N栋、宿舍M栋" & "<P></P>" & Wt2
.WriteLn Wt1 & "占地面积8888平方米" & "<P></P>" & Wt2
.WriteLn Wt1 & "注册资金:666万人民币" & "<P></P>" & Wt2
.WriteLn Wt1 & "主产电脑主板和内存" & "<P></P>" & Wt2
.WriteLn Wt1 & "年产量主板20万块,内存30万条" & "<P></P>" & Wt2
.WriteLn Wt1 & "物品出口额达每年5000万元" & "<P></P>" & Wt2
.WriteLn Wt1 & "本公司以诚信为本" & "<P></P>" & Wt2
.WriteLn Wt1 & "质量第一 顾客至上" & "<P></P>" & Wt2
.WriteLn Wt1 & "产品获ISO 9002质量体系认证" & "<P></P>" & Wt2
.WriteLn Wt1 & "公司环境符合ISO 14000认证" & "<P></P>" & Wt2
.WriteLn Wt1 & "绝对值得你信任" & "<P></P>" & Wt2
.WriteLn Wt1 & "<hr>" & "<P></P>" & Wt2
.WriteLn Wt1 & "本公司双休制" & "<P></P>" & Wt2
.WriteLn Wt1 & "周一至周五营业" & "<P></P>" & Wt2
.WriteLn Wt1 & "欢迎随时来电恰谈业务" & "<P></P>" & Wt2
.WriteLn Wt1 & "将由前台专人接待" & "<P></P>" & Wt2
.WriteLn Wt1 & "本公司电话:" & "<P></P>" & Wt2
.WriteLn Wt1 & "85868788" & "<P></P>" & Wt2
.WriteLn Wt1 & "本公司传真:" & "<P></P>" & Wt2
.WriteLn Wt1 & "88878685" & "<P></P>" & Wt2
.WriteLn Wt1 & "<HR>" & "<P></P>" & Wt2
.WriteLn Wt1 & "以上纯属虚构!" & "<P></P>" & Wt2
.WriteLn Wt1 & D1 & "联系人:<a href='mailto:andy_qc@163.com'>
andy_qc@163.com</a></p>" & Wt2
.WriteLn Wt1 & "</Font>" & Wt2
.WriteLn Wt1 & "</Marquee>" & Wt2
.WriteLn "</SCRIPT>"
End With
WebBrowser1.Refresh2
End Sub
② 为了不让窗口通过右上角关闭按钮关闭,加入以下代码:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode <> 1 Then Cancel = True '不允许关闭窗体
End Sub
③ 第二页“输入人事资料”,为了让按钮突出鼠标移过特效,使用“MouseMove”事件对按钮和按钮文字进行设置:
Private Sub MultiPage1_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim i As Byte '鼠标移过多页控件时发生此事件
For i = 1 To 4
With Me.Controls("CommandButton" & i) '分别对四个按钮进行设置
.Font.Italic = False '加粗字体
.Font.Size = 10 '加大字号
.BackColor = &H8000000F '修改按钮颜色
End With
Next i
End Sub
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With CommandButton1
.Font.Italic = True
.Font.Size = 12
.BackColor = &HFFC0C0
.MousePointer = fmMousePointerHelp
End With
End Sub
Private Sub CommandButton2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With CommandButton2
.Font.Italic = True
.Font.Size = 12
.BackColor = &HFFC0C0
.MousePointer = fmMousePointerHelp
End With
End Sub
Private Sub CommandButton3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With CommandButton3
.Font.Italic = True
.Font.Size = 12
.BackColor = &HFFC0C0
.MousePointer = fmMousePointerHelp
End With
End Sub
Private Sub CommandButton4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With CommandButton4
.Font.Italic = True
.Font.Size = 12
.BackColor = &HFFC0C0
.MousePointer = fmMousePointerHelp
End With
End Sub
④ “输入人事资料”页第一个按钮“新增档案”代码:
Private Sub CommandButton1_Click() '单击新增按钮时执行
Dim a As Byte, b As Long, c
If Me.TextBox1 = "" Then MsgBox "请输入姓名!": TextBox1.SetFocus: Exit Sub
'未输入姓名则退出程序
If Me.TextBox7 = "" Then MsgBox "请输入身份证号!": TextBox7.SetFocus:
Exit Sub '未输入身份证号则退出程序
If Me.TextBox8 = "" Then MsgBox "请为新员分配工号!": TextBox8.SetFocus:
Exit Sub '未输入工号则退出程序
b = ThisWorkbook.Sheets("人事资料").Range("a65536").End(xlUp).Row + 1
'求出A列第一个空行行号
If WorksheetFunction.CountIf(Sheets("人事资料").Range("G3:G" & b), TextBox7) = 0 Then '如果输入的身份证号码未与工作表中G列数据重复
If WorksheetFunction.CountIf(Sheets("人事资料").Range("H3:H" & b), TextBox8) <> 0 Then '如果输入的工号与工作表中H列数据重复
MsgBox "已存在该工号,请重新分配一个工号", 32, "友情提示" '那么提示数据重复
TextBox8.SetFocus '激活输入工号的文本框
Exit Sub '退出程序
Else '否则
For a = 1 To 10 '前10个录入的数据逐个加入到工作表中
ThisWorkbook.Sheets("人事资料").Cells(b, a) = Me.Controls ("textbox" & a)
Me.Controls("textbox" & a) = "" '清除控件值
Next a
End If
Else
MsgBox "表中已存在此身份证号码,请核对后再输入。", 32, "友情提示"
'如果录入的身份证号与G列数据重复
TextBox7.SetFocus '激活输入身份证的文本框
Exit Sub
End If
TextBox1.SetFocus '激活输入姓名的文本框
End Sub
⑤ 第二个按钮“打印厂牌”代码:
Private Sub CommandButton2_Click() '单击打印厂牌按钮时执行
Application.Visible = True
ThisWorkbook.Sheets("厂牌打印").Select
Unload Me
End Sub
⑥ 第三个按钮“工资表”代码:
Private Sub CommandButton4_Click() '单击工资表按钮时执行
Application.Visible = True
ThisWorkbook.Sheets("工资表").Select
Unload Me
End Sub
⑦ 第四个按钮“退出程序”代码:
Private Sub CommandButton3_Click() '单击退出按钮时执行
Application.Quit
End Sub
(4)“厂牌打印”工作表中按钮代码和单击列表框的代码(第一个程序为“姓名为”按钮对应的宏程序;第二个为单击列表框时更新厂牌打印区的引用数据)
Sub 姓名() '当人事资料更新后用此程序更新列表框内容
Dim a
a = WorksheetFunction.CountA(Sheets("人事资料").Columns("A:A"))
'记录“人事资料”表数据个数
ActiveWorkbook.Names.Add Name:="姓名", RefersToR1C1:="=人事资料!
R3C1:R" & a & "C3" '添加名称
With Me.ListBox1
.ListFillRange = "姓名" '将名称所引用的数据加入到列表框中
.ColumnHeads = True '让列表框显示表头
.ColumnCount = 3 '显示三列
.ColumnWidths = "50,50,50" '设置列宽
.BackColor = &HFFC0C0 '设置颜色
.ListStyle = fmListStyleOption '设置样式
End With
End Sub
Private Sub ListBox1_Change() '单击列表框时执行
On Error Resume Next
Range("c4") = ListBox1.Value 'C4单元格等于列表框的值
'到人事资料表中已用区域查找列表框的值,若找到则取其所在行第8列和第9列的值
Range("c6") = WorksheetFunction.VLookup(ListBox1.Value, Sheets
("人事资料").Range("a2").CurrentRegion, 8, 0)
Range("c8") = WorksheetFunction.VLookup(ListBox1.Value, Sheets
("人事资料").Range("a2").CurrentRegion, 9, 0)
End Sub
① 启动人事资料管理工作簿。
② 程序弹出验证对话框,同时隐藏工作簿界面。若直接单击“确定”按钮,系统将弹出警告如图17.16所示;若输入用户名不是“andy”、“sky”或者“andysky”,则系统弹出警告如图17.17所示。
③ 若用户名正确,但输入密码非“admin”,则系统弹出提示如图17.18所示;若连续三次输入错误,则系统弹出提示如图17.19所示,单击“确定”按钮后Excel即立即关闭。
④ 如果用鼠标单击窗体右上角红色关闭按钮,可以发现程序已将之锁定,没有任何反应;用快捷键Alt+F4仍然如此,开启工作簿必须输入正确的密码。
⑤ 当输入正确的用户名和密码后,登录窗口关闭,同时系统弹出欢迎窗口,提示如图17.20所示。
⑥ 单击“确定”按钮后,出现“人事资料管理”主窗口,其首页的公司简介反复地从下向上滚动,当鼠标移过时则停止滚动,移到旁边则继续滚动;单击公司简介中的邮件地址,程序将启动Outlook,如图17.21所示。
⑦ 单击第二页“输入人事资料”,鼠标移过任意按钮时,按钮变色显示,同时字体加大、倾斜以突显选项,如图17.22所示。
⑧ 直接单击“新增档案”按钮,程序弹出提示“请输入姓名!”,如图17.23所示。
⑨ 在第一个文本框中输入姓名后,按回车键,光标自动定位于第二个文本框“性别”框中,依此类推,输入所有信息都只需要按回车键,不需要单击鼠标。当最后光标定位于“新增档案”按钮上时,按回车键,程序将所有信息导出到工作表中,同时清空所有文本框信息,光标自动定位于第一个文本框等待输入下一笔资料。
⑩ 第二笔资料中在“身份证”框录入与前资料相同的号码,当单击“新增档案”按钮时,程序将弹出已存在该身份证号码的提示,如图17.24所示。同时光标定位于身份证号码输入框,等待重新输入。
预购地址:http://www.china-pub.com/39292
【出版日期】 2008 年3月 【开 本】 16开 【页 码】 585 【作 者】罗刚君 【出 版 社】 电子工业出版社 【书 号】 9787121057793
2、人性化讲解..
3、实力派作者队伍
实力派作者,350个范例,让您全面掌握Excel VBA。
5大措施,更方便读者学习...
- 人事资料管理
- 人事资料修复
- 人事综合管理系统开发
- 人事
- e-人事管理系统-招聘管理-人事推荐
- 管理资料
- 金友通用大型工资/人事/考勤管理系统 bt
- 《德鲁克管理思想精要》读书笔记5 - 人事、创新、创业
- SM04 在线用户管理(踢人事务)
- 知识管理资料
- DB2管理资料
- 营销管理资料下载
- 电脑资料管理多面手
- 资料管理网站考虑
- 资料管理助手
- 视觉资料管理
- 视觉资料管理
- 视觉资料管理
- Potential Errors Passing CRT Objects Across DLL Boundaries
- Delphi设计模式之单例模式(Singleton Pattern)
- 如何写DLL
- Tomcat 5.5 连接池 CLOB
- 系统经常假死该如何解决
- 人事资料管理
- 如何控制在父子窗体中只打开一次子窗体
- 【转自百度】北京IT培训机构就业率调研
- 开机BIOS语言
- C# 判断文件夹是否为空
- 为什么总是后悔曾经努力工作 马润梅
- ARM920T的MMU与Cache ——转载
- jBPM项目总结
- 被迫的思考...