VBA常用技巧代码解析

yuanzhuping

技巧198         职工考勤系统
       步骤5，将Sheet3工作表名称重命名为“考勤统计”，设置成如图所示的格式，用来汇总部门考勤考核数据及打印“考勤统计”表。

       步骤6，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件及两个按钮控件，在框架控件中添加四个标签控件、一个组合框控件、一个文本框控件和一个SpinButton控件，如图所示。

       双击窗体，在打开的代码窗口写入下面的代码：

1. #001  Private Sub UserForm_Initialize()
   
2. #002      Dim i As Integer
   
3. #003      For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
   
4. #004          ComboBox1.AddItem Sheet1.Cells(i, 1)
   
5. #005      Next
   
6. #006      ComboBox1.ListIndex = 0
   
7. #007      Label4 = Sheet1.Range("B1")
   
8. #008      SpinButton1.Value = Month(Date)
   
9. #009      TextBox1.Text = Year(Date) & "年" & Month(Date) & "月"
   
10. #010  End Sub

复制代码

代码解析：
       部门考勤窗体的初始化事件，为组合控件添加部门名称，为文本框控件添加考勤月份。
       双击窗体上的SpinButton控件，在打开的代码窗口写入下面的代码：

1. #001  Private Sub SpinButton1_Change()
   
2. #002      With SpinButton1
   
3. #003          Select Case .Value
   
4. #004              Case 1 To 12
   
5. #005                  TextBox1 = Left(TextBox1, 4) & "年" & .Value & "月"
   
6. #006              Case Is > 12
   
7. #007                  .Value = 1
   
8. #008                  TextBox1 = Left(TextBox1, 4) + 1 & "年" & .Value & "月"
   
9. #009              Case Is < 1
   
10. #010                  .Value = 12
    
11. #011                  TextBox1 = Left(TextBox1, 4) - 1 & "年" & .Value & "月"
    
12. #012          End Select
    
13. #013      End With
    
14. #014  End Sub

复制代码

代码解析：
       SpinButton控件的Change事件，调节文本框控件中的考勤月份。
       双击窗体上的“确定”按钮，在打开的代码窗口写入下面的代码：

1. #001  Private Sub CommandButton1_Click()
   
2. #002      Dim s As Integer
   
3. #003      Dim Sh As Worksheet
   
4. #004      Dim arr As Variant
   
5. #005      Dim arrName As Variant
   
6. #006      Dim i As Integer
   
7. #007      Dim i1 As Integer
   
8. #008      Dim j As Integer
   
9. #009      Dim j1 As Integer
   
10. #010      Dim r As Integer
    
11. #011      Dim c As Integer
    
12. #012      Dim str As String
    
13. #013      Dim d As Integer
    
14. #014      Application.ScreenUpdating = False
    
15. #015      Application.DisplayAlerts = False
    
16. #016      For s = Worksheets.Count To 4 Step -1
    
17. #017          Worksheets(s).Delete
    
18. #018      Next
    
19. #019      Application.DisplayAlerts = True
    
20. #020      With Sheet1
    
21. #021          For i = 4 To .Range("A65536").End(xlUp).Row
    
22. #022              If ComboBox1.Text = .Cells(i, 1) And .Cells(i, 4) = "" Then
    
23. #023                  MsgBox "请增加部门人员!", 64, "提示"
    
24. #024                  Unload Me
    
25. #025                  Exit Sub
    
26. #026              End If
    
27. #027          Next
    
28. #028      End With
    
29. #029      With Sheet3
    
30. #030          .Unprotect
    
31. #031          r = .Range("B65536").End(xlUp).Row
    
32. #032          If r >= 50 Then
    
33. #033              .Rows("50:" & r).Delete Shift:=xlUp
    
34. #034          End If
    
35. #035          .Range("B1") = Sheet1.Range("B1") & "出缺勤统计表"
    
36. #036          .Range("C2") = ComboBox1.Text
    
37. #037          .Range("O2") = TextBox1.Text
    
38. #038          For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
    
39. #039              If ComboBox1.Text = Sheet1.Cells(i, 1) Then
    
40. #040                  r = Sheet1.Cells(i, 255).End(xlToLeft).Column
    
41. #041                  .Range("C30") = Sheet1.Cells(i, 2)
    
42. #042                  .Range("O30") = Sheet1.Cells(i, 3)
    
43. #043                  For c = 4 To r
    
44. #044                      .Cells(c + 46, 2) = Sheet1.Cells(i, c)
    
45. #045                  Next
    
46. #046              End If
    
47. #047          Next
    
48. #048          r = .Range("B65536").End(xlUp).Row
    
49. #049          .Range("I50:I" & r).FormulaR1C1 = "=SUM(RC[-4]:RC[-1])"
    
50. #050          .Range("M50:M" & r).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
    
51. #051          .Range("B50:O" & r).Borders.LineStyle = xlContinuous
    
52. #052          .Range("C50:C" & r).Locked = False
    
53. #053          .Range("E50:H" & r).Locked = False
    
54. #054          .Range("J50:L" & r).Locked = False
    
55. #055          .ScrollArea = ""
    
56. #056          Application.Goto Reference:=.Range("A50"), Scroll:=True
    
57. #057          .ScrollArea = "A50:O" & r
    
58. #058          .Protect
    
59. #059          .EnableSelection = xlUnlockedCells
    
60. #060      End With
    
61. #061      For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
    
62. #062          If ComboBox1.Text = Sheet1.Cells(i, 1) Then
    
63. #063              c = i
    
64. #064              For j = 4 To Sheet1.Cells(i, 255).End(xlToLeft).Column
    
65. #065                  str = str & Sheet1.Cells(i, j) & ","
    
66. #066              Next
    
67. #067          End If
    
68. #068      Next
    
69. #069      arrName = Split(Left(str, (Len(str) - 1)), ",")
    
70. #070      For i1 = 0 To UBound(arrName)
    
71. #071          Set Sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
72. #072          With Sh
    
73. #073              .Name = arrName(i1)
    
74. #074              arr = Array(1.75, 4.5, 3, 3, 3, 3, 45, 9, 1.75)
    
75. #075              For i = LBound(arr) To UBound(arr)
    
76. #076                  .Columns(i + 1).ColumnWidth = arr(i)
    
77. #077              Next
    
78. #078              arr = Array(33, 24, 18)
    
79. #079              For i = LBound(arr) To UBound(arr)
    
80. #080                  .Rows(i + 1).RowHeight = arr(i)
    
81. #081              Next
    
82. #082              .Rows("4:36").RowHeight = 16.5
    
83. #083              .Rows(37).RowHeight = 30
    
84. #084              .Range("B1:H1,B2:H2,C4:D4,E4:F4,B4:B5,G4:G5,H4:H5,B37:G37").Merge
    
85. #085              With .Range("B4:H37")
    
86. #086                  .Borders.LineStyle = xlContinuous
    
87. #087                  .BorderAround xlDouble
    
88. #088              End With
    
89. #089              With .Range("B1")
    
90. #090                  .HorizontalAlignment = xlCenter
    
91. #091                  .Value = Sheet1.Range("B1") & "人员考核记录表"
    
92. #092                  .Font.Name = "黑体"
    
93. #093                  .Font.Size = 16
    
94. #094                  .Font.Bold = True
    
95. #095              End With
    
96. #096              With .Range("B2")
    
97. #097                  .HorizontalAlignment = xlCenter
    
98. #098                  .Value = TextBox1.Text
    
99. #099                  .Font.Bold = True
    
100. #100              End With
     
101. #101              With .Range("B3")
     
102. #102                  .Value = "姓名：" & arrName(i1)
     
103. #103                  .HorizontalAlignment = xlLeft
     
104. #104                  .Font.Size = 10
     
105. #105              End With
     
106. #106              With .Range("B4：H37")
     
107. #107                  .HorizontalAlignment = xlCenter
     
108. #108                  .Font.Size = 10
     
109. #109              End With
     
110. #110              .Range("B4").Value = "日" & Chr(10) & "期"
     
111. #111              .Range("C4").Value = "上午"
     
112. #112              .Range("E4").Value = "下午"
     
113. #113              .Range("G4").Value = "工作内容（加班情况或外出记录）"
     
114. #114              .Range("H4").Value = "备注"
     
115. #115              .Range("C5,E5").Value = "到"
     
116. #116              .Range("D5,F5").Value = "缺"
     
117. #117              .Range("B37").Value = "本月考核得分总计"
     
118. #118              With .Range("B38")
     
119. #119                  .Value = "部门负责人：" & Sheet1.Cells(c, 2)
     
120. #120                  .HorizontalAlignment = xlLeft
     
121. #121                  .Font.Size = 10
     
122. #122              End With
     
123. #123              With .Range("H38")
     
124. #124                  .Value = "考勤员：" & Sheet1.Cells(c, 3)
     
125. #125                  .Font.Size = 10
     
126. #126                  .HorizontalAlignment = xlRight
     
127. #127              End With
     
128. #128              Select Case Val(Sheet1.Cells(2, 2))
     
129. #129                  Case 26 To 28
     
130. #130                      If Month(TextBox1.Text & "1日") <> 1 Then
     
131. #131                          .Cells(6, 2) = Year(TextBox1.Text & "1日") & "-" & Month(DateAdd("m", -1, TextBox1.Text & "1日")) & "-" & Val(Sheet1.Cells(2, 2))
     
132. #132                      Else
     
133. #133                          .Cells(6, 2) = (Year(TextBox1.Text & "1日") - 1) & "-" & Month(DateAdd("m", -1, TextBox1.Text & "1日")) & "-" & Val(Sheet1.Cells(2, 2))
     
134. #134                      End If
     
135. #135                  Case 1 To 5
     
136. #136                      .Cells(6, 2) = Year(TextBox1.Text & "1日") & "-" & Month(TextBox1.Text & "1日") & "-" & Val(Sheet1.Cells(2, 2))
     
137. #137              End Select
     
138. #138              For i = 1 To 30
     
139. #139                  Cells(i + 6, 2) = .Cells(6, 2) + i
     
140. #140                  If .Cells(i + 6, 2).Value = DateAdd("m", 1, .Cells(6, 2)) - 1 Then Exit For
     
141. #141              Next
     
142. #142              .Range("B6:B36").NumberFormatLocal = "d"
     
143. #143              For i = 6 To 36
     
144. #144                  If .Cells(i, 2) <> "" Then
     
145. #145                      Select Case DatePart("w", .Cells(i, 2))
     
146. #146                          Case 7, 1
     
147. #147                              .Cells(i, 7) = "休  息"
     
148. #148                          Case 2, 3, 4, 5, 6
     
149. #149                              .Cells(i, 3) = "√"
     
150. #150                              .Cells(i, 5) = "√"
     
151. #151                              .Cells(i, 7) = "上  班"
     
152. #152                              d = d + 1
     
153. #153                      End Select
     
154. #154                      Select Case Mid(Cells(i, 2), 6, Len(Cells(i, 2)) - 5)
     
155. #155                          Case "01-01"
     
156. #156                              .Cells(i, 3) = ""
     
157. #157                              .Cells(i, 5) = ""
     
158. #158                              .Cells(i, 7) = "元  旦"
     
159. #159                              d = d - 1
     
160. #160                          Case "05-01"
     
161. #161                              .Cells(i, 3) = ""
     
162. #162                              .Cells(i, 5) = ""
     
163. #163                              .Cells(i, 7) = "五一节"
     
164. #164                              d = d - 1
     
165. #165                          Case "10-01", "10-02", "10-03"
     
166. #166                              .Cells(i, 3) = ""
     
167. #167                              .Cells(i, 5) = ""
     
168. #168                              .Cells(i, 7) = "国庆节"
     
169. #169                              d = d - 1
     
170. #170                      End Select
     
171. #171                      Select Case Mid(NongLi(Cells(i, 2)), 9, 5)
     
172. #172                          Case "正月初一", "正月初二", "正月初三"
     
173. #173                              .Cells(i, 3) = ""
     
174. #174                              .Cells(i, 5) = ""
     
175. #175                              .Cells(i, 7) = "春  节"
     
176. #176                              d = d - 1
     
177. #177                          Case "四月初四"
     
178. #178                              .Cells(i, 3) = ""
     
179. #179                              .Cells(i, 5) = ""
     
180. #180                              .Cells(i, 7) = "清明节"
     
181. #181                              d = d - 1
     
182. #182                          Case "五月初五"
     
183. #183                              .Cells(i, 3) = ""
     
184. #184                              .Cells(i, 5) = ""
     
185. #185                              .Cells(i, 7) = "端午节"
     
186. #186                              d = d - 1
     
187. #187                          Case "八月十五"
     
188. #188                              .Cells(i, 3) = ""
     
189. #189                              .Cells(i, 5) = ""
     
190. #190                              .Cells(i, 7) = "中秋节"
     
191. #191                              d = d - 1
     
192. #192                      End Select
     
193. #193                  End If
     
194. #194              Next
     
195. #195              .Range("E3") = d
     
196. #196              d = 0
     
197. #197              .Range("H3").FormulaR1C1 = "=(COUNTA(R[3]C[-5]:R[33]C[-5],R[3]C[-3]:R[33]C[-3],""√"""""")-1)/2"
     
198. #198              .Range("H37").FormulaR1C1 = "=ROUND(IF(R[-34]C/R[-34]C[-3]*100>100,100,R[-34]C/R[-34]C[-3]*100),0)"
     
199. #199              .Range("E3,H3").Font.ColorIndex = 2
     
200. #200              .Range("C6:G36").Locked = False
     
201. #201              .Rows("6").Select
     
202. #202              .PageSetup.CenterHorizontally = True
     
203. #203              .DisplayAutomaticPageBreaks = False
     
204. #204              With ActiveWindow
     
205. #205                  .DisplayGridlines = False
     
206. #206                  .DisplayHeadings = False
     
207. #207                  .DisplayOutline = False
     
208. #208                  .FreezePanes = True
     
209. #209                  .DisplayGridlines = False
     
210. #210              End With
     
211. #211              .ScrollArea = "B1:O42"
     
212. #212              .Range("G6").Select
     
213. #213              .Protect
     
214. #214              .EnableSelection = xlUnlockedCells
     
215. #215          End With
     
216. #216      Next
     
217. #217      Sheets("考勤统计").Select
     
218. #218      Unload Me
     
219. #219      Application.ScreenUpdating = True
     
220. #220  End Sub

复制代码

代码解析：
       部门考勤窗体中“确定”按钮的单击事件，将所考勤部门的人员姓名写入到“考勤统计”表的姓名列中并在工作簿中该部门所有人员的个人考核表。
       第15行到第19行代码，删除工作簿中原有的个人考核表。
       第20行到第28行代码，判断所要考勤的部门是否已添加了部门人员。
       第32行到第34行代码，删除“考勤统计”表中原有的统计数据，因为“考勤统计”表中B1：O30的表格是打印表格用的，统计数据是保存在B50以下单元格中，所以考勤前需要删除。
       第35行代码，将单位名称写入到“考勤统计”表的B1单元格。
       第36行代码，将考勤部门写入到“考勤统计”表的C2单元格。
       第4行代码，将考勤月份写入到“考勤统计”表的O2单元格。
       第41行代码，将部门负责人写入到“考勤统计”表的C30单元格。
       第42行代码，将考勤员写入到“考勤统计”表的O30单元格。
       第43行到第45行代码，将“资料”表中所保存的该部门人员姓名写入“考勤统计”表的B50及B50往下单元格中。
       第49、50行代码，在“考勤统计”表的I50、M50及以下单元格中写入合计公式并将单元格属性设置为锁定。
       第51行代码，将“考勤统计”表的B50至O列的最后一行单元格添加边框线。
       第52行到第54行代码，取消“考勤统计”表中需要编辑单元格的锁定属性。
       第55行到第57行代码，将“考勤统计”表的可选择区域设置为B50至O列的最后一行单元格并使用Goto方法选择B50单元格。
       第58、59行代码，保护“考勤统计”表，使之只能选择未锁定的单元格。
       写入考勤数据的“考勤统计”表如图所示。

       第61行到第69代码，将该部门保存在“资料”表中的人员姓名赋给数组arrName。
       第70、71行代码，根据数组arrName保存的人员姓名依次在工作簿中添加个人考核表。
       第73行代码，将添加的工作表以人员姓名重新命名。
       第74行到第83行代码，设置个人考核表的行高、列宽。
       第84行代码，合并个人考核表中的单元格。
       第85行到第88行代码，设置个人考核表的边框线。
       第59行到第127行代码，在个人考核表写入表格内容并设置格式。
       第128行到第142行代码，在个人考核表的日期栏中根据考勤月份及考勤周期写入考勤日期并设置自定义格式。
       第145行到第153行代码，使用DatePart函数判断考勤日期的星期并在个人考核表的“到”栏和“工作内容”栏中写入系统默认的内容，其中第152行代码，将应出勤天数赋给变量d。
       第154行到第170行代码，判断考勤日期是否是“元旦”、“五一节”及“国庆节”，如果是则去除个人考核表的“到”栏中的应出勤标志，在“工作内容”栏中写入节假日名称并将应出勤天数减去放假天数。
       第171行到第192行代码，判断考勤日期是否是“春节”、“清明节”、“端午节”及“中秋节”，如果是则去除个人考核表的“到”栏中的应出勤标志，在“工作内容”栏中写入节假日名称并将应出勤天数减去放假天数。
       判断考勤日期的农历日期需使用自定义函数，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

1. #001  Public Function NongLi(Optional XX_DATE As Date)
   
2. #002      Dim MonthAdd(11), NongliData(99), TianGan(9), DiZhi(11), ShuXiang(11), DayName(30), MonName(12)
   
3. #003      Dim curTime, curYear, curMonth, curDay
   
4. #004      Dim GongliStr, NongliStr, NongliDayStr
   
5. #005      Dim i, m, n, k, isEnd, bit, TheDate
   
6. #006      代码略，详见附件
   
7. #007      NongliStr = "农历" & TianGan(((curYear - 4) Mod 60) Mod 10) & DiZhi(((curYear - 4) Mod 60) Mod 12) & "年"
   
8. #008      NongliStr = NongliStr & "(" & ShuXiang(((curYear - 4) Mod 60) Mod 12) & ")"
   
9. #009      If (curMonth < 1) Then
   
10. #010          NongliDayStr = "闰" & MonName(-1 * curMonth)
    
11. #011      Else
    
12. #012          NongliDayStr = MonName(curMonth)
    
13. #013      End If
    
14. #014      NongliDayStr = NongliDayStr & "月"
    
15. #015      NongliDayStr = NongliDayStr & DayName(curDay)
    
16. #016      NongLi = NongliStr & NongliDayStr
    
17. #017  End Function

复制代码

自定义NongLi函数根据日期生成农历天干、地支、属相等，来自网络，未做任何修改。其中第171行代码使用Mid函数取得农历日期。
       第195行代码，将统计出的应出勤天数写入到个人考核表的E3单元格。
       第197行代码，在个人考核表的H3单元格中写入统计实际出勤天数的公式。
       第198行代码，在个人考核表的H36单元格中写入计算考核得分的公式。
       第199行到第216行代码，设置个人考核表的页面格式及工作表保护。
       添加好的个人考核表如图所示。

       在实际应用时，系统统计出的出勤数据与实际出勤数据可能有出入，为了方便修改数据，在VBE中双击ThisWorkbook写入下面的代码：

1. #001  Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
2. #002      If Sh.Index > 3 And Target.Count = 1 Then
   
3. #003          If Sh.Range("B" & Target.Row) <> "" Then
   
4. #004              If Not Application.Intersect(Target, Union(Sh.Range("C6:C36"), Sh.Range("E6:E36"))) Is Nothing Then
   
5. #005                  Target = "√"
   
6. #006                  Target.Offset(, 1) = ""
   
7. #007              End If
   
8. #008              If Not Application.Intersect(Target, Union(Sh.Range("D6:D36"), Sh.Range("F6:F36"))) Is Nothing Then
   
9. #009                  Target = "△"
   
10. #010                  Target.Offset(, -1) = ""
    
11. #011              End If
    
12. #012          End If
    
13. #013      End If
    
14. #014  End Sub

复制代码

代码解析：
       工作簿的SheetSelectionChange事件，选择个人考核表中的“到”或“缺”栏中的单元格时，自动在单元格中写入出缺勤标志。

1. #001  Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   
2. #002      Dim rng As Range
   
3. #003      If Sh.Index > 3 And Target.Count = 1 Then
   
4. #004          If Sh.Range("B" & Target.Row) <> "" Then
   
5. #005              If Not Application.Intersect(Target, Sh.Range("C6:F36")) Is Nothing Then
   
6. #006                  Select Case Target
   
7. #007                      Case "√"
   
8. #008                          Sh.Range("G" & Target.Row) = "上  班"
   
9. #009                      Case "△"
   
10. #010                          Sh.Range("G" & Target.Row) = "缺  勤"
    
11. #011                      End Select
    
12. #012              End If
    
13. #013          End If
    
14. #014      End If
    
15. #015  End Sub

复制代码

代码解析：
       工作簿的SheetChange事件，根据个人考核表中的“到”或“缺”栏中写入出缺勤标志自动调整工作内容栏中的工作内容。

yuanzhuping

技巧198         职工考勤系统
       步骤7，在实际应用中，因为隐藏了工作表标签，当需要选择个人考核表时，只能使用自定义的菜单，所以在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

1. #001  Sub check()
   
2. #002      On Error GoTo Line
   
3. #003      Sheets(4).Activate
   
4. #004      Exit Sub
   
5. #005  Line:
   
6. #006      MsgBox "本月还没有考勤,请先考勤!", 64, "提示"
   
7. #007  End Sub

复制代码

代码解析：
       Check过程激活工作簿中的第四张工作表，也就是第一张个人考核表。如果还没有进行部门考勤，激活命令会发生错误，所以使用On Error语句执行第6行代码进行提示。
       在修改个人考核表过程中，需要在工作簿中进行上下翻页，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

1. #001  Sub NextPage()
   
2. #002      Select Case ActiveSheet.Index
   
3. #003          Case Is < 4
   
4. #004              MsgBox "请选择【个人考核】按纽!", 64, "提示"
   
5. #005          Case Is = Worksheets.Count
   
6. #006              MsgBox "已经是最后一页!", 64, "提示"
   
7. #007          Case Else
   
8. #008              Sheets(ActiveSheet.Index + 1).Activate
   
9. #009      End Select
   
10. #010  End Sub

复制代码

代码解析：
       NextPage过程通过活动工作表的Index属性判断活动工作表是否在个人考核表的范围内，如果在则激活活动工作表的下一张工作表，否则进行提示。

1. #011  Sub Onpage()
   
2. #012      Select Case ActiveSheet.Index
   
3. #013          Case Is < 4
   
4. #014              MsgBox "请选择【个人考核】按纽!", 64, "提示"
   
5. #015          Case Is = 4
   
6. #016              MsgBox "已经是第一页!", 64, "提示"
   
7. #017          Case Else
   
8. #018              Sheets(ActiveSheet.Index - 1).Activate
   
9. #019      End Select
   
10. #020  End Sub

复制代码

代码解析：
       Onpage过程通过活动工作表的Index属性判断活动工作表是否在个人考核表的范围内，如果在则激活活动工作表的上一张工作表，否则进行提示。
       步骤8，当所有的个人考核表修改完成后，需要对个人考核数据进行汇总，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

1. #001  Sub Gather()
   
2. #002      Dim i As Integer
   
3. #003      If Worksheets.Count < 4 Then
   
4. #004          MsgBox "本月还没有考勤,请先进行部门考勤!", 64, "提示"
   
5. #005          Exit Sub
   
6. #006      End If
   
7. #007      With Sheet3
   
8. #008          .Select
   
9. #009          If MsgBox("是否汇总" & .Range("C2") & .Range("O2").Text & "份的考勤记录?", 36, "提示") = 6 Then
   
10. #010              .Unprotect
    
11. #011              For i = 50 To .Range("B65536").End(xlUp).Row
    
12. #012                  If .Cells(i, 2) <> "" Then
    
13. #013                  .Cells(i, 3) = Sheets(i - 46).Range("E3")
    
14. #014                  .Cells(i, 4) = Sheets(i - 46).Range("H3")
    
15. #015                  .Cells(i, 14) = Sheets(i - 46).Range("H37")
    
16. #016                  End If
    
17. #017              Next
    
18. #018          .Protect
    
19. #019          End If
    
20. #020      End With
    
21. #021  End Sub

复制代码

代码解析：
       Gather过程将每个职工的个人考核表中的考核数据汇总到“考勤统计”表。
       第3行到第6行代码，判断是否已进行了部门考勤，因为如果还没有进行部门考勤，工作簿中只有三张工作表。
       第11行到第16行代码，将个人考核表中的应出勤天数、实际出勤天数及考核得分写入到“考勤统计”表第50行主以下的单元格中。因为“考勤统计”表中的姓名和个人考核表的工作表名称的顺序是一致的，所以只需按顺序写入即可。如果应出勤天数与实际情况有出入可以在“考勤统计”表的C列单元格中进行修改。
       步骤9，当汇总好考核数据后，需要打印“考勤统计”表和所有的个人考核表，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

1. #001  Sub stamp()
   
2. #002      Dim i As Integer
   
3. #003      Dim r As Integer
   
4. #004      Dim a As Integer
   
5. #005      Dim p As Integer
   
6. #006      Dim c As Integer
   
7. #007      If Worksheets.Count < 4 Then
   
8. #008          MsgBox "本月还没有考勤,请先进行部门考勤!", 64, "提示"
   
9. #009          Exit Sub
   
10. #010      End If
    
11. #011      With Sheet3
    
12. #012          .Select
    
13. #013          If .Range("C50") = "" Then
    
14. #014              MsgBox "请先汇总考核数据!", 64, "提示"
    
15. #015              Exit Sub
    
16. #016          End If
    
17. #017          Application.ScreenUpdating = False
    
18. #018          If MsgBox("是否打印" & .Range("C2") & .Range("O2").Text & "份的考勤记录?", 36, "提示") = 7 Then
    
19. #019              Exit Sub
    
20. #020          End If
    
21. #021          .Unprotect
    
22. #022          r = .Range("B63536").End(xlUp).Row
    
23. #023          a = Abs(Int(-(r - 49) / 25))
    
24. #024          For p = 1 To a
    
25. #025              For i = 5 To 29
    
26. #026                  For c = 2 To 15
    
27. #027                      .Cells(i, c) = .Cells(i + 45 + (p - 1) * 25, c)
    
28. #028                  Next
    
29. #029              Next
    
30. #030              .PrintOut
    
31. #031          Next
    
32. #032          For i = 4 To Worksheets.Count
    
33. #033              Sheets(i).PrintOut
    
34. #034          Next
    
35. #035          .Protect
    
36. #036          .EnableSelection = 1
    
37. #037          Application.ScreenUpdating = True
    
38. #038      End With
    
39. #039  End Sub

复制代码

代码解析：
       stamp过程打印“考勤统计”表和所有的个人考核表。
       第7行到第10行代码，判断是否已进行了部门考勤，因为如果还没有进行部门考勤，工作簿中只有三张工作表。
       第13行到第16行代码，判断是否已将考核数据进行汇总。
       第22、23行代码，计算“考勤统计”表需打印的张数，因为预设的表格只有25行，如果部门人数超过25人需要进行分次打印。
       第24行到第31行代码，将考核数据每次25行写入到打印表格中进行打印。
       第32行到第34行代码，打印所有人员的个人考核表。
       步骤10，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个Image控件、一个框架控件及一个按钮控件，在框架控件中添加一个Image控件和一个标签控件，将Image控件的Picture属性设置为合适的图片，如图 所示。

       双击窗体，在打开的代码窗口写入下面的代码：

1. #001  Private Sub UserForm_Initialize()
   
2. #002      Dim Note As String
   
3. #003      Note = "名称： 职工考勤系统" & vbLf _
   
4. #004          & "版本： V2.0" & vbLf _
   
5. #005          & "作者： yuanzhuping" & vbLf _
   
6. #006          & "E-mail： yuanzhuping@yeah.net "
   
7. #007      Label1.Caption = Note
   
8. #008  End Sub

复制代码

代码解析：
       “关于”窗体的初始化事件，使用标签控件显示系统信息。
       步骤11，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件及一个按钮控件，在框架控件中添加一个标签控件，如图所示。

       双击窗体，在打开的代码窗口写入下面的代码：

1. #001  Private Sub UserForm_Initialize()
   
2. #002      Dim Note As String
   
3. #003      …………代码略，详见附件
   
4. #004      With Label1
   
5. #005          .Caption = Note
   
6. #006          .Height = 296
   
7. #007          .Top = 6
   
8. #008          .Left = 6
   
9. #009          Frame1.ScrollBars = fmScrollBarsVertical
   
10. #010          Frame1.ScrollHeight = .Height
    
11. #011      End With
    
12. #012  End Sub

复制代码

代码解析：
       “帮助”窗体的初始化事件，使用标签控件显示帮助信息。请参阅技巧122 。
       步骤12，在实际应用中，需要在菜单栏上添加自定义菜单来使用各项功能，在VBE窗口中单击菜单“插入”→“模块”，在模块中写入下面的代码：

1. #001  Sub AddNowBar()
   
2. #002      Dim NewBar As CommandBar
   
3. #003      On Error Resume Next
   
4. #004      With Application
   
5. #005          .CommandBars("Standard").Visible = False
   
6. #006          .CommandBars("Formatting").Visible = False
   
7. #007          .CommandBars("Stop Recording").Visible = False
   
8. #008          .CommandBars("toolbar list").Enabled = False
   
9. #009          .CommandBars.DisableAskAQuestionDropdown = True
   
10. #010          .DisplayFormulaBar = False
    
11. #011          .DisplayStatusBar = False
    
12. #012          .CommandBars("NewBar").Delete
    
13. #013      End With
    
14. #014      Set NewBar = Application.CommandBars.Add(Name:="NewBar", Position:=msoBarTop, MenuBar:=True, Temporary:=True)
    
15. #015      。。。。。。。。。代码略，详见附件
    
16. #016      End With
    
17. #017      Set NewBar = Nothing
    
18. #018      Application.StatusBar = ""
    
19. #019  End Sub
    
20. #020  Sub DelNowBar()
    
21. #021      On Error Resume Next
    
22. #022      With Application
    
23. #023          .CommandBars("Standard").Visible = True
    
24. #024          .CommandBars("Formatting").Visible = True
    
25. #025          .CommandBars("Stop Recording").Visible = True
    
26. #026          .CommandBars("toolbar list").Enabled = True
    
27. #027          .CommandBars.DisableAskAQuestionDropdown = False
    
28. #028          .DisplayFormulaBar = True
    
29. #029          .DisplayStatusBar = True
    
30. #030          .CommandBars("NewBar").Delete
    
31. #031          Application.StatusBar = False
    
32. #032      End With
    
33. #033  End Sub

复制代码

代码解析：
       第1行到第19行代码，AddNowBar过程，去除工作簿中的菜单栏、工具栏、编辑栏及状态栏等，添加自定义的菜单栏。
       第20行到第33行代码，DelNowBar过程，恢复系统原来的设置。
       关于自定义菜单请参阅技巧83 。
       自定义菜单如图所示。

       为了使用自定义菜单，除了以上已经解析过的过程以外，还需在VBE窗口中单击菜单“插入”→“模块”，在模块中写入下面的代码：

1. #001  Sub SetUnits()
   
2. #002      If Sheet1.Cells(1, 2) <> "" Then
   
3. #003          If MsgBox("是否重新设置使用单位？", 36, "提示") = 7 Then
   
4. #004              Exit Sub
   
5. #005          End If
   
6. #006      End If
   
7. #007      单位设置.Show
   
8. #008  End Sub
   
9. #009  Sub Setbranch()
   
10. #010      If Sheet1.Cells(1, 2) = "" Then
    
11. #011          MsgBox "请先设置使用单位!", 36, "提示"
    
12. #012          Exit Sub
    
13. #013      End If
    
14. #014      部门设置.Show
    
15. #015  End Sub
    
16. #016  Sub Setcrew()
    
17. #017      If Sheet1.Cells(4, 1) = "" Then
    
18. #018          MsgBox "请先设置使用部门!", 64, "提示"
    
19. #019          Exit Sub
    
20. #020      End If
    
21. #021      人员设置.Show
    
22. #022  End Sub
    
23. #023  Sub Attendance()
    
24. #024      If Sheet1.Cells(4, 1) = "" Then
    
25. #025          MsgBox "请先设置使用部门!", 64, "提示"
    
26. #026          Exit Sub
    
27. #027      End If
    
28. #028      部门考勤.Show
    
29. #029  End Sub
    
30. #030  Sub backtrack()
    
31. #031      Sheet2.Select
    
32. #032  End Sub
    
33. #033  Sub ThemeHelp()
    
34. #034      关于.Show
    
35. #035  End Sub
    
36. #036  Sub OnHelp()
    
37. #037      帮助.Show
    
38. #038  End Sub
    
39. #039  Sub myQuit()
    
40. #040      If Workbooks.Count > 1 Then
    
41. #041          ThisWorkbook.Close
    
42. #042      Else
    
43. #043          Application.Quit
    
44. #044      End If
    
45. #045  End Sub

复制代码

代码解析：
       第1行到第8行代码，“系统设置”菜单中的“单位设置”菜单指定的过程，显示“单位设置”窗体。
       第9行到第15行代码，“系统设置”菜单中的“部门设置”菜单指定的过程，显示“部门设置”窗体。
       第16行到第22行代码，“系统设置”菜单中的“人员设置”菜单指定的过程，显示“人员设置”窗体。
       第23行到第29行代码，“部门考勤”菜单指定的过程，显示“部门考勤”窗体。其中第24行到第27行代码判断是否已设置了使用部门。
       第30行到第32行代码，“返回”菜单指定的过程，选择主界面表。
       第33行到第35行代码，“帮助”菜单中的“关于”菜单指定的过程，显示“关于”窗体。
       第36行到第38行代码，“帮助”菜单中的“帮助”菜单指定的过程，显示“帮助”窗体。
       第39行到第45行代码，“退出系统”菜单指定的过程，根据当前打开的工作簿数量采用Close方法关闭工作簿或Quit方法关闭应用程序。
       步骤13，为了在使用过程中有一个友好的用户界面，将Sheet2表重命名为“欢迎”，在工作表中插入合适的图片，在图片上添加标签控件并把宏指定给标签控件。

1. 步骤14，在VBE窗口中双击“ThisWorkbook”，在打开的代码窗口中写入下面的代码：
   
2. #001  Private Sub Workbook_Open()
   
3. #002      With Sheet2
   
4. #003          .ScrollArea = "A1"
   
5. #004          .Select
   
6. #005      End With
   
7. #006  End Sub
   
8. #007  Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
9. #008      Dim s As Integer
   
10. #009      Application.ScreenUpdating = False
    
11. #010      Application.DisplayAlerts = False
    
12. #011      For s = Worksheets.Count To 4 Step -1
    
13. #012          Worksheets(s).Delete
    
14. #013      Next
    
15. #014      Application.DisplayAlerts = True
    
16. #015      Application.ScreenUpdating = True
    
17. #016      ThisWorkbook.Save
    
18. #017  End Sub
    
19. #018  Private Sub Workbook_Activate()
    
20. #019      Application.Caption = IIf(Sheet1.Cells(1, 2) <> "", Sheet1.Cells(1, 2), "")
    
21. #020      Call AddNowBar
    
22. #021  End Sub
    
23. #022  Private Sub Workbook_Deactivate()
    
24. #023      Application.Caption = ""
    
25. #024      Call DelNowBar
    
26. #025  End Sub

复制代码

代码解析：
       第1行到第6行代码，工作簿的Open事件，打开考勤系统时选择欢迎界面。
       第7行到第17行代码，工作簿的BeforeClose事件，关闭考勤系统时删除所有的个人考核表。
       第18行到第21行代码，工作簿的Activate事件，考勤系统激活时创建自定义菜单。
       第22行到第25行代码，工作簿的Deactivate事件，考勤系统非激活时删除自定义菜单。
       步骤15，最后在VBE中将“资料”表的Visible属性设置为xlSheetVeryHidden使之隐藏；单击菜单“工具”→“数字签名”，为VBA工程签署数字证书。
       保存、关闭工作簿，重新打开工作簿，职工考勤系统如图所示。


技巧198职工考勤系统附件
技巧198 职工考勤系统.rar (132.1 KB, 下载次数: 2746)

2009-9-7 08:37 上传

点击文件名下载附件

biaotiger1

EH中有太多太多的珍珠，因为年代久远而蒙尘或失踪
感谢斑竹的辛勤工作
为我等菜鸟悉心整理并费心解析

收藏，慢慢学习
谢谢谢谢

kevindy

感谢版主的辛勤付出。

sunie05

受益了，谢谢

lano

正在学习VBA啊

davyguan

收藏了  好东西呀 收藏了  好东西呀 收藏了  好东西呀

myvolcano

好东东，顶顶顶！！！！！！！！！！！！！！！！！！！！！！！！！！！！

zds1711jl

我是初学者，受教了，努力学习中，谢谢楼主了！！！

入孝出悌

太谢谢！袁版主使我获益匪浅！