VBA常用技巧代码解析

absconder

技巧29在运行时，老是跳出如下一个对话框：
无法在未启用宏的工作簿中保存以下功能：VB项目
附件上传不上来.....
说我的图片是无效的图片文件....
那我把提示信息都写出来吧....

若要使保存的文件具有这些功能,请点击"否",然后从文件类型中选择一个启用宏的文件类型.
若要继续保存未启用宏的工作簿,请点"是"...

问题是,,我点否,后,,看那列表,启用宏的工作簿 的扩展名为xlsm,怎么没有扩展名为xls的...
我看这论坛中的Excel都是xls的啊?

yuanzhuping

扩展名为xls的是2003版本，xlsm是2007版本的，2007我没用过，不是太清楚。

yuanzhuping

我们学习VBA的目的就是学以致用，简化日常工作，提高工作效率。下面介绍一些本人正在使用的实例，这些实例虽然只是行业应用，并不具备通用性，但对大家如何使用VBA制作适合自己的应用系统具有一定的借鉴作用。具体的代码就不一一解析了，大家会发现这些代码在上面的技巧中基本都能找到，主要解析制作的思路和过程，供大家参考。

技巧193         加班费计算表
       财务人员在工作中经常需要计算职工的加班费，在计算过程中需要根据职工的技能工资、岗位工资之和除以21天得到日工资标准，再根据当月的加班天数乘以相应的系数才能计算出加班费总额，计算时非常的烦琐，很不方便。使用Excel制作的加班费计算表可以很方便的计算职工的加班费。
       步骤1，新建工作簿，将Sheet2工作表重命名为“人员信息”，在第一行中写入所需信息的字段名称，如图所示。

       步骤2，所需的人员信息无需在工作表中一一输入，前四个可以从工资软件中导出的文本文件中获取，后两个可以使用代码自动生成。在VBE窗口中插入模块，写入下面的代码。

1. #001  Sub ImportWages()
   
2. #002      Dim GetName As Variant
   
3. #003      Dim TxtPath As String
   
4. #004      Dim TxtName As String
   
5. #005      Dim Tbtext As String
   
6. #006      Dim sField As String
   
7. #007      Dim Cnn As ADODB.Connection
   
8. #008      Dim rs As New ADODB.Recordset
   
9. #009      Dim r As Integer
   
10. #010      Dim i As Integer
    
11. #011      Dim b As Integer
    
12. #012      Dim StrName As String
    
13. #013      If MsgBox("是否重新导入工资表数据?", vbQuestion + vbYesNo, "系统提示") = vbNo Then: Exit Sub
    
14. #014      On Error GoTo line
    
15. #015      GetName = Application.GetOpenFilename(Title:="导入工资", fileFilter:="All files (*.*),*.*")
    
16. #016      With Sheet2
    
17. #017          .Select
    
18. #018          .Unprotect
    
19. #019          If GetName <> False Then
    
20. #020              TxtPath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(GetName)
    
21. #021              TxtName = CreateObject("Scripting.FileSystemObject").GetFileName(GetName)
    
22. #022              Tbtext = " [Text;DATABASE=" & TxtPath & "]." & TxtName
    
23. #023              Set Cnn = New ADODB.Connection
    
24. #024              Cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
    
25. #025              rs.Open "select 人员编号,姓名,技能工资,岗位工资 from " & Tbtext, Cnn
    
26. #026              r = .Range("A65536").End(xlUp).Row
    
27. #027              If r >= 3 Then .Range("A3:F" & r).ClearContents
    
28. #028              .Range("A3").CopyFromRecordset rs
    
29. #029              r = .Range("A65536").End(xlUp).Row
    
30. #030              .Range("A" & r & ":F" & r).ClearContents
    
31. #031              For i = 3 To r
    
32. #032                  StrName = ""
    
33. #033                  For b = 1 To Len(.Cells(i, 2))
    
34. #034                      If Asc(Mid$(.Cells(i, 2), b, 1)) > 255 Or Asc(Mid$(.Cells(i, 2), b, 1)) < 0 Then
    
35. #035                          StrName = StrName & LChin(Mid$(.Cells(i, 2), b, 1))
    
36. #036                      Else
    
37. #037                          StrName = StrName & LCase(Mid$(.Cells(i, 2), b, 1))
    
38. #038                      End If
    
39. #039                  Next b
    
40. #040                  .Cells(i, 5) = Round((Val(.Cells(i, 3)) + Val(.Cells(i, 4))) / 21, 2)
    
41. #041                  .Cells(i, 6) = StrName
    
42. #042              Next i
    
43. #043          End If
    
44. #044          .Protect
    
45. #045      End With
    
46. #046      Exit Sub
    
47. #047  line:
    
48. #048      MsgBox "请选择正确的文本文件!", 64, "系统提示"
    
49. #049  End Sub

复制代码

代码解析：
       ImportWages过程从工资软件导出的文本文件中导入人员的工资信息并计算日工资、生成助记码。
       第13行代码，确认是否需要重新导入工资信息。
       第14行代码，错误处理语句。在第25行代码中，如果打开的文件不是从工资软件中导出的文本文件，会因找不到所查询的字段名称而发生错误。
       第15行代码，使用GetOpenFilename方法显示“打开”对话框，用来获得从工资软件中导出的文本文件的文件路径。关于GetOpenFilename方法请参阅77-2。
       第18行代码，取消Sheet2表的工作表保护。
       第19行到第21行代码，如果在“打开”对话框中选择了文件并按下了“打开”按钮使用GetParentFolderName方法将返回的路径中的文件路径赋给字符串变量TxtPath，使用GetFileName方法将返回的路径中的包含扩展名的文件名称赋给字符串变量TxtName。关于FileSystemObject对象的一些方法请参阅技巧180 。
       第22行到第25行代码，使用ADO语句从选择文本文件中查询需要的数据。其中第25行代码设置需查询数据的字段名称。
       第26、27行代码，使用ClearContents方法清除表中原来的数据。
       第28行代码，将查询到数据写入到工作表中。
       第29、30行代码，使用ClearContents方法清除导入数据的最后一行，即最后的合计行。
       第31行到第39行代码，根据B列中的人员姓名生成助记码，方便在使用时输入人员姓名。请参阅技巧114 。
       第40行代码，根据C列的技能工资和D列的岗位工资计算日工资标准并写入到E列中。
       第41行代码，将生成的人员姓名助记码写入到F列中。
       第44行代码，使用Protect方法保护Sheet2表。
       第48行代码，如果文件选择错误，使用消息框进行提示。
       运行ImportWages过程将显示一个“打开”对话框用来获得需打开的工资表文件的路径及文件名称，如图所示。

       当选择好最新的工资表文件后单击“打开”按钮，将最新的工资数据导入到Sheet2表中，如图所示。

      在ImportWages过程的第35行代码使用自定义LChin函数将中文字符转换为拼音首字母，需要在模块中写入下面的代码。

1. #001  Public Function LChin(Str As String) As Variant
   
2. #002      On Error Resume Next
   
3. #003      Str = StrConv(Str, vbNarrow)
   
4. #004      If Asc(Str) > 0 Or Err.Number = 1004 Then LChin = ""
   
5. #005      LChin = WorksheetFunction.VLookup(Str, [{"吖","a";"八","b";"嚓","c";"咑","d";"鵽","e";"发","f";"猤","g";"铪","h";"夻","j";"咔","k";"垃","l";"嘸","m";"旀","n";"噢","o";"妑","p";"七","q";"囕","r";"仨","s";"他","t";"屲","w";"夕","x";"丫","y";"帀","z"}], 2)
   
6. #006  End Function

复制代码

关于拼音首字母的转化请参阅技巧114 中的相关内容。

yuanzhuping

步骤3，将Sheet1工作表重命名为“加班费计算”并设置成如图所示。

       步骤4，为了方便输入人员姓名，需要输入时能逐步提示信息，而工作表的单元格处于编辑状态时是无法运行宏代码，所以需要在Sheet1表中添加一个文本框控件和一个列表框控件，文本框用来代替单元格进行输入，列表框显示提示的信息。
       为了使文本框控件和列表框控件只有在需要输入人员姓名时显示，在Sheet1表写入下面的代码。

1. #001  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. #002      Dim i As Integer
   
3. #003      Dim r As Integer
   
4. #004      Dim arr As Variant
   
5. #005      r = Sheet1.Range("B63556").End(xlUp).Row
   
6. #006      If Target.Count = 1 Then
   
7. #007          If Target.Column = 2 And Target.Row > 4 And Target.Row < r Then
   
8. #008              If Target.Row = r - 1 Then
   
9. #009                  Sheet1.Unprotect
   
10. #010                  Rows(r).Insert Shift:=xlDown
    
11. #011                  Sheet1.Protect
    
12. #012              End If
    
13. #013              With Me.TextBox1
    
14. #014                  .Visible = True
    
15. #015                  .Top = Target.Top
    
16. #016                  .Left = Target.Left
    
17. #017                  .Width = Target.Width
    
18. #018                  .Height = Target.Height
    
19. #019              End With
    
20. #020              With Me.ListBox1
    
21. #021                  .Visible = True
    
22. #022                  .Top = Target.Top
    
23. #023                  .Left = Target.Offset(, 1).Left
    
24. #024                  .Width = 80
    
25. #025                  .Height = Target.Height * 8
    
26. #026                  .ColumnCount = 2
    
27. #027                  .ColumnWidths = "30,45"
    
28. #028                  arr = Sheet2.Range("A3:B" & Sheet2.[B63556].End(xlUp).Row)
    
29. #029                  .Column = Application.WorksheetFunction.Transpose(arr)
    
30. #030              End With
    
31. #031          Else
    
32. #032              Me.ListBox1.Clear
    
33. #033              Me.TextBox1 = ""
    
34. #034              Me.ListBox1.Visible = False
    
35. #035              Me.TextBox1.Visible = False
    
36. #036          End If
    
37. #037      End If
    
38. #038  End Sub

复制代码

代码解析：
       工作表的SelectionChange事件，当选择工作表的B列单元格时显示文本框控件和列表框控件供输入人员姓名。请参阅技巧114 中的相关内容。
       当选择Sheet1表的B列单元格时效果如图所示。

       为了输入时能逐步提示信息，在文本框控件和列表框控件中写入下面的代码。

1. #001  Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
2. #002      Dim i As Integer
   
3. #003      Dim Language As String
   
4. #004      Dim myStr As String
   
5. #005      Me.ListBox1.Clear
   
6. #006      With Me.TextBox1
   
7. #007          For i = 1 To Len(.Value)
   
8. #008              Select Case Asc(Mid$(.Value, i, 1))
   
9. #009                  Case 48 To 56
   
10. #010                      Language = "S"
    
11. #011                      myStr = myStr & Mid$(.Value, i, 1)
    
12. #012                  Case Is < 0, Is > 255
    
13. #013                      Language = "Z"
    
14. #014                      myStr = myStr & Mid$(.Value, i, 1)
    
15. #015                  Case Else
    
16. #016                      Language = "P"
    
17. #017                      myStr = myStr & LCase(Mid$(.Value, i, 1))
    
18. #018              End Select
    
19. #019          Next
    
20. #020      End With
    
21. #021      With Sheet2
    
22. #022          For i = 3 To .Range("A65536").End(xlUp).Row
    
23. #023              Select Case Language
    
24. #024                  Case "S"
    
25. #025                      If Left(.Cells(i, 1).Value, Len(myStr)) = myStr Then
    
26. #026                          Me.ListBox1.AddItem
    
27. #027                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .Cells(i, 1).Value
    
28. #028                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value
    
29. #029                      End If
    
30. #030                  Case "Z"
    
31. #031                      If Left(.Cells(i, 2).Value, Len(myStr)) = myStr Then
    
32. #032                          Me.ListBox1.AddItem
    
33. #033                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .Cells(i, 1).Value
    
34. #034                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value
    
35. #035                      End If
    
36. #036                  Case Else
    
37. #037                      If Left(.Cells(i, 6).Value, Len(myStr)) = myStr Then
    
38. #038                          Me.ListBox1.AddItem
    
39. #039                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .Cells(i, 1).Value
    
40. #040                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value
    
41. #041                      End If
    
42. #042              End Select
    
43. #043          Next
    
44. #044      End With
    
45. #045  End Sub

复制代码

代码解析：
       文本框的KeyUp事件，在文本框中输入姓名时根据输入的内容进行逐步提示，可以使用三种方法进行输入，人员编号、中文字符和拼音首字母。
       第7行到第19行代码，使用字符串变量Language保存输入的方式，字符串变量myStr保存输入的内容。
       第21行到第42行代码，根据输入方法的不同，在Sheet2表的不同列中查找符合字符串变量myStr的单元格，并赋给列表框控件。

1. #001  Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
2. #002      If KeyCode = vbKeyReturn Then
   
3. #003          Sheet1.ListBox1.Activate
   
4. #004      End If
   
5. #005  End Sub

复制代码

代码解析：
       文本框的KeyDown事件，在文本框中输入查询条件，当列表框中出现符合条件的数据后按回车键后选择列表框，方便输入。

1. #001  Private Sub ListBox1_GotFocus()
   
2. #002      On Error Resume Next
   
3. #003      ListBox1.ListIndex = 0
   
4. #004  End Sub

复制代码

代码解析：
       列表框的GotFocus事件，当列表框激活后选择第一条条目，以便用户按上下键进行选择或按回车键后输入到工作表中。

1. #001  Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
2. #002      On Error Resume Next
   
3. #003      If KeyCode = vbKeyReturn Then
   
4. #004          Sheet1.Unprotect
   
5. #005          ActiveCell.Value = Me.ListBox1.Column(1)
   
6. #006          ActiveCell.Offset(, -1).Value = Me.ListBox1.Column(0)
   
7. #007          Me.ListBox1.Clear
   
8. #008          Me.TextBox1 = ""
   
9. #009          Me.ListBox1.Visible = False
   
10. #010          Me.TextBox1.Visible = False
    
11. #011          Sheet1.Protect
    
12. #012      End If
    
13. #013  End Sub

复制代码

代码解析：
       列表框的KeyDown事件，按回车键后将列表框中选择的条目输入到工作表中，并清除文本框和列表框的内容后隐藏，以便下一次输入。

1. #001  Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
2. #002      On Error Resume Next
   
3. #003      Sheet1.Unprotect
   
4. #004      ActiveCell.Value = Me.ListBox1.Column(1)
   
5. #005      ActiveCell.Offset(, -1).Value = Me.ListBox1.Column(0)
   
6. #006      Me.ListBox1.Clear
   
7. #007      Me.TextBox1 = ""
   
8. #008      Me.ListBox1.Visible = False
   
9. #009      Me.TextBox1.Visible = False
   
10. #010      Sheet1.Protect
    
11. #011  End Sub

复制代码

代码解析：
       列表框的DblClick事件，双击列表框中选择的条目，输入到工作表中，并清除文本框和列表框的内容后隐藏，以便下一次输入。输入时逐步提示信息请参阅技巧114 。

yuanzhuping

步骤5，为了在输入人员姓名后在Sheet1工作表的C列中写入相应的日工资标准，在Sheet1工作表的写入下面的代码。

1. #001  Private Sub Worksheet_Change(ByVal Target As Range)
   
2. #002      Dim rng As Range
   
3. #003      Dim r As Integer
   
4. #004      On Error Resume Next
   
5. #005      With Target
   
6. #006          If .Row > 4 And .Count = 1 Then
   
7. #007              If .Column = 1 Then
   
8. #008                  r = Sheet2.Range("A63556").End(xlUp).Row
   
9. #009                  For Each rng In Sheet2.Range("A3:A" & r)
   
10. #010                      If rng.Text Like .Text Then
    
11. #011                          .Offset(, 2).Value = rng.Offset(, 4).Value
    
12. #012                      End If
    
13. #013                  Next
    
14. #014              End If
    
15. #015              If .Column = 2 Then
    
16. #016                  If .Text = "" Then
    
17. #017                      Application.EnableEvents = False
    
18. #018                      Sheet1.Unprotect
    
19. #019                      Rows(.Row).Delete
    
20. #020                      Sheet1.Protect
    
21. #021                      Application.EnableEvents = True
    
22. #022                  End If
    
23. #023              End If
    
24. #024              
    
25. #025          End If
    
26. #026      End With
    
27. #027  End Sub

复制代码

代码解析：
       Sheet1工作表的Change事件，当输入人员编号和人员姓名后，将对应的日工资标准写入到Sheet1工作表的C列中。
       第6行代码设置事件的触发条件。
       第7行到第14行代码，删除B列单元格中的人员姓名则同时删除对应的人员编号和日工资标准。
       第18行到第29行代码，检查输入的人员姓名是否重复。因为单位中可能有重复的人员姓名，但是人员编号是唯一的，所以根据人员编号检查输入的人员姓名是否重复。
       第30行到第34行代码，使用Like方法在根据人员编号在Sheet2表的A列中查找相对应的人员编号，找到后将日工资标准写入到Sheet1工作表的C列中。
       在Sheet1工作表的B列中输入人员姓名后效果如图所示。

       步骤6，在某些情况下，可能需要输入全部人员的姓名，比如在笔者单位每年的7、8月份要发放高温加班工资，这时可以从Sheet2表中将所有人员的姓名和编号导入到Sheet1表中，需要在模块中写入下面的代码。

1. #001  Sub ImportName()
   
2. #002      Dim r1 As Integer
   
3. #003      Dim r2 As Integer
   
4. #004      Dim i As Long
   
5. #005      r1 = Sheet1.Range("B63556").End(xlUp).Row
   
6. #006      r2 = Sheet2.Range("B63556").End(xlUp).Row
   
7. #007      If MsgBox("确定要导入所有人员姓名吗", 32 + vbYesNo, "系统提示") = vbNo Then Exit Sub
   
8. #008      Application.ScreenUpdating = False
   
9. #009      With Sheet1
   
10. #010          .Select
    
11. #011          .Unprotect
    
12. #012          If r1 <= r2 + 3 Then .Rows(r1).Resize(r2 - r1 + 4).Insert
    
13. #013          For i = 5 To Sheet1.Range("B63556").End(xlUp).Row - 2
    
14. #014              .Cells(i, 1) = Sheet2.Cells(i - 2, 1)
    
15. #015              .Cells(i, 2) = Sheet2.Cells(i - 2, 2)
    
16. #016          Next
    
17. #017          .Protect
    
18. #018      End With
    
19. #019      Application.ScreenUpdating = True
    
20. #020  End Sub

复制代码

代码解析：
       ImportName过程将Sheet2工作表的人员姓名导入到Sheet1工作表的B列单元格中。
       第5、6行代码，取得两个工作表中现有数据的行号。
       第12行代码，根据两个工作表中现有数据的行号决定在到Sheet1工作表需要插入的行数。
       第13行第16行代码，将Sheet2工作表的人员编号和人员姓名导入到Sheet1工作表的B列单元格中，因为在写入的过程中同时会触发工作表的Change事件，所以日工资标准无需导入。
       如果有少量不需要计算的人员姓名可以在导入后删除。
       步骤7，如果在输入时Sheet1工作表中已有数据，可以先进行清除，在模块中写入下面的代码。

1. #001  Sub DataClear()
   
2. #002      Dim r As Integer
   
3. #003      With Sheet1
   
4. #004          .Select
   
5. #005          If MsgBox("是否清除加班费数据?", 32 + vbYesNo, "系统提示") = vbNo Then Exit Sub
   
6. #006          .Unprotect
   
7. #007          r = .Range("B63556").End(xlUp).Row
   
8. #008          If r >= 6 Then
   
9. #009              .Rows("5:" & r - 2).Delete
   
10. #010          End If
    
11. #011          r = .Range("B63556").End(xlUp).Row
    
12. #012          Union(.Cells(2, 12), .Range(.Cells(r, 5), .Cells(r, 12))).ClearContents
    
13. #013          .Protect
    
14. #014          Application.GoTo Reference:=.Cells(5, 4), Scroll:=True
    
15. #015      End With
    
16. #016  End Sub

复制代码

代码解析：
       DataClear过程清除计算表中已有的数据。
       步骤8，在VBE中插入一个窗体，用于计算加班费时选择计算的月份并对Sheet2表的D、F、H和J列中输入的加班班数计算应发的加班费合计，如图所示。
        
       双击窗体写入下面的代码。

1. #001  Private Sub UserForm_Initialize()
   
2. #002      SpinButton1.Value = Year(Date)
   
3. #003      SpinButton2.Value = Month(Date)
   
4. #004      TextBox1.Text = Year(Date) & "年"
   
5. #005      TextBox2.Text = Month(Date) & "月份"
   
6. #006  End Sub

复制代码

代码解析：
       窗体的Initialize事件，在窗体初始化时文本框中显示当前的年月。
       双击窗体中的SpinButton控件，写入下面的代码。

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

复制代码

代码解析：
       使用SpinButton控件调节窗体中显示的年月，请参阅技巧140 。
       双击窗体中的“确定”按钮，写入下面的代码。

1. #001  Private Sub CommandButton1_Click()
   
2. #002      Dim i As Integer
   
3. #003      Dim r As Integer
   
4. #004      With Sheet1
   
5. #005          .Select
   
6. #006          r = .Range("B63556").End(xlUp).Row
   
7. #007          If .Cells(5, 2) = "" Then
   
8. #008              MsgBox "请把数据填写完整后再计算!", 64, "系统提示"
   
9. #009              Unload Me
   
10. #010              Exit Sub
    
11. #011          End If
    
12. #012          For i = 5 To r - 2
    
13. #013              If WorksheetFunction.CountIf(.Range("B5:B" & i), .Cells(i, 2)) > 1 Then
    
14. #014                  If MsgBox(.Cells(i, 2) & "输入重复,是否继续?", 36, "系统提示") = 7 Then
    
15. #015                      Unload Me
    
16. #016                      Exit Sub
    
17. #017                  End If
    
18. #018              End If
    
19. #019          Next
    
20. #020          .Unprotect
    
21. #021          .Cells(2, 12) = TextBox2.Text
    
22. #022          For i = 5 To r - 1
    
23. #023              .Cells(i, 5) = Round(100 * .Cells(i, 4), 2)
    
24. #024              .Cells(i, 7) = Round(.Cells(i, 3) * 1.5 * .Cells(i, 6), 2)
    
25. #025              .Cells(i, 9) = Round(.Cells(i, 3) * 2 * .Cells(i, 8), 2)
    
26. #026              .Cells(i, 11) = Round(.Cells(i, 3) * 3 * .Cells(i, 10), 2)
    
27. #027              .Cells(i, 12) = .Cells(i, 5) + .Cells(i, 7) + .Cells(i, 9) + .Cells(i, 11)
    
28. #028          Next
    
29. #029              .Cells(r, 5) = WorksheetFunction.Sum(.Range("E5:E" & r - 1))
    
30. #030              .Cells(r, 7) = WorksheetFunction.Sum(.Range("G5:G" & r - 1))
    
31. #031              .Cells(r, 9) = WorksheetFunction.Sum(.Range("I5:I" & r - 1))
    
32. #032              .Cells(r, 11) = WorksheetFunction.Sum(.Range("K5:K" & r - 1))
    
33. #033              .Cells(r, 12) = WorksheetFunction.Sum(.Range("L5:L" & r - 1))
    
34. #034          .Protect
    
35. #035      End With
    
36. #036      Unload Me
    
37. #037      MsgBox TextBox1.Text & TextBox2.Text & "的加班费已计算完毕!", 64, "系统提示"
    
38. #038  End Sub

复制代码

代码解析：
       窗体中的“确定”按钮的Click事件过程，计算Sheet1表中的加班费合计。
       第7行到第11行代码，检查Sheet1表中是否已输入人员姓名及加班班数。
       第12行到第19行代码，检查Sheet1表中的人员编号是否重复。
       第21行代码，在Sheet1表中写入所计算的月份。
       第22行到第28行代码，根据加班班数和相应的系数计算加班费金额。
       第29行到第33行代码，计算合计栏的金额。
       在Sheet1表中输入人员姓名和加班天数后按窗体的“确定”按钮后效果如图所示。

       为了计算高温加班工资，VBE中插入一个和计算加班费类似的窗体，双击窗体中的“确定”按钮，写入下面的代码。

1. #001  Private Sub CommandButton1_Click()
   
2. #002      Dim rng As Range
   
3. #003      Dim i As Integer
   
4. #004      Dim r As Integer
   
5. #005      With Sheet1
   
6. #006          r = .Range("B63556").End(xlUp).Row
   
7. #007          .Select
   
8. #008          If .Cells(5, 2) = "" Then
   
9. #009              MsgBox "请把数据填写完整后再计算!", 64, "系统提示"
   
10. #010              Unload Me
    
11. #011              Exit Sub
    
12. #012          End If
    
13. #013          For i = 5 To r - 2
    
14. #014              If WorksheetFunction.CountIf(.Range("B5:B" & i), .Cells(i, 2)) > 1 Then
    
15. #015                  If MsgBox(.Cells(i, 2) & "输入重复,是否继续?", 36, "系统提示") = 7 Then
    
16. #016                      Unload Me
    
17. #017                      Exit Sub
    
18. #018                  End If
    
19. #019              End If
    
20. #020          Next
    
21. #021          Application.ScreenUpdating = False
    
22. #022          .Unprotect
    
23. #023          .Cells(2, 12) = TextBox2.Text
    
24. #024          With Sheet2.Range("A:A")
    
25. #025              For i = 5 To r - 1
    
26. #026                  Set rng = .Find(What:=Cells(i, 1).Value, _
    
27. #027                      After:=.Cells(.Cells.Count), _
    
28. #028                      LookIn:=xlFormulas, _
    
29. #029                      LookAt:=xlWhole, _
    
30. #030                      SearchOrder:=xlByRows, _
    
31. #031                      SearchDirection:=xlNext, _
    
32. #032                      MatchCase:=False)
    
33. #033                  If Not rng Is Nothing Then
    
34. #034                      Sheet1.Cells(i, 12) = Round(((Val(rng.Offset(0, 2)) + Val(rng.Offset(0, 3))) / 2), 2)
    
35. #035                  End If
    
36. #036              Next
    
37. #037          End With
    
38. #038          .Cells(r, 12) = WorksheetFunction.Sum(.Range("L5:L" & r - 1))
    
39. #039          .Protect
    
40. #040      End With
    
41. #041      Application.ScreenUpdating = True
    
42. #042      Unload Me
    
43. #043      MsgBox TextBox1.Text & TextBox2.Text & "的高温工资计算完毕!", 64, "系统提示"
    
44. #044  End Sub

复制代码

代码解析：
       窗体中的“确定”按钮的Click事件过程，计算Sheet1表中的高温工资。
       第8行到第12行代码，检查Sheet1表中是否已输入人员姓名。
       第13行到第20行代码，检查Sheet1表中的人员编号是否重复。
       第23行代码，在Sheet1表中写入所计算的月份。
       第24行到第37行代码，根据Sheet1表中的人员编号在Sheet2表中查找对应的“技能工资”和“岗位工资”并将其合计数的二分之一写入到Sheet1表中。（笔者所在单位每年发一次高温加班工资，为职工“技能工资”和“岗位工资”之和，分两个月发放）
       第38行代码，计算合计栏的金额。
       在Sheet1表中输入人员姓名和加班天数后按窗体的“确定”按钮后效果如图所示。

yuanzhuping

步骤8，加班费计算完毕后，需要进行汇总，以便统计全年的加班费总额。将Sheet3工作表重命名为“加班费汇总”并设置成如图所示的格式，在A列和B列中分别写入人员编号和姓名。

       在模块中写入下面的代码。

1. #001  Sub DataSummary()
   
2. #002      Dim MyMonth As String
   
3. #003      Dim c As Integer
   
4. #004      Dim rng As Range
   
5. #005      Dim r As Integer
   
6. #006      Dim i As Integer
   
7. #007      MyMonth = Sheet1.Cells(2, 12).Value
   
8. #008      If MsgBox("是否汇总加班费数据?", 36, "系统提示") = 7 Then
   
9. #009          Exit Sub
   
10. #010      End If
    
11. #011      If Sheet1.Cells(5, 12) = "" Then
    
12. #012          MsgBox "没有可汇总的数据,请先计算加班费!", 64, "系统提示"
    
13. #013          Exit Sub
    
14. #014      End If
    
15. #015      With Sheet3
    
16. #016          r = .Range("A63556").End(xlUp).Row
    
17. #017          For i = 3 To 14
    
18. #018              If .Cells(1, i).Value = MyMonth Then
    
19. #019                  c = i
    
20. #020                  Exit For
    
21. #021              End If
    
22. #022          Next
    
23. #023          If .Cells(r, c).Value > 0 Then
    
24. #024              If MsgBox(MyMonth & "加班费已经汇总,是否继续?", 36, "系统提示") = 7 Then
    
25. #025              Exit Sub
    
26. #026          End If
    
27. #027          End If
    
28. #028          .Unprotect
    
29. #029          Application.ScreenUpdating = False
    
30. #030          With .Range("A:A")
    
31. #031              For i = 5 To Sheet1.Range("A63556").End(xlUp).Row
    
32. #032                  Set rng = .Find(What:=Sheet1.Cells(i, 1).Text, _
    
33. #033                      After:=.Cells(.Cells.Count), _
    
34. #034                      LookIn:=xlFormulas, _
    
35. #035                      LookAt:=xlWhole, _
    
36. #036                      SearchOrder:=xlByRows, _
    
37. #037                      SearchDirection:=xlNext, _
    
38. #038                      MatchCase:=False)
    
39. #039                  If Not rng Is Nothing Then
    
40. #040                      rng.Offset(, c - 1) = Val(rng.Offset(, c - 1)) + Val(Sheet1.Cells(i, 12))
    
41. #041                  End If
    
42. #042              Next
    
43. #043          End With
    
44. #044         .Cells(r, c).ClearContents
    
45. #045          For i = 2 To r - 1
    
46. #046              .Cells(r, c) = Val(.Cells(r, c)) + Val(.Cells(i, c))
    
47. #047          Next
    
48. #048          For i = 2 To r
    
49. #049              .Cells(i, 15) = WorksheetFunction.Sum(.Range("C" & i & ":N" & i))
    
50. #050          Next
    
51. #051          Application.GoTo Reference:=.Cells(1, c), Scroll:=True
    
52. #052          .Protect
    
53. #053      End With
    
54. #054      Application.ScreenUpdating = True
    
55. #055      MsgBox MyMonth & "的加班费汇总完毕!", 64, "系统提示"
    
56. #056  End Sub

复制代码

代码解析：
       DataSummary过程将“加班费计算”表中计算好的加班费合计汇总到“加班费汇总”表中。
       第8行代码获得需要汇总的月份。
       第17行到第22行代码，获得需要汇总的月份在“加班费汇总”表中的列号。
       第23行代码到第27行代码，如果“加班费汇总”表中相应的列中已有合计金额，询问是否继续汇总，防止重复汇总。
       第30行到第43行代码，使用Find方法将加班费金额进行汇总。关于Find方法请参阅技巧5-1。
       第44行到第50行代码在汇总表中重新计算每行每列的合计数。
       第51行代码使用GoTo方法选择汇总表中相应的单元格。关于GoTo方法请参阅技巧2-3。
       步骤9，加班费计算、汇总完毕后需要进行打印，首先在工作表窗口中单击菜单“文件”→“页面设置”，在“工作表”选项卡中将“顶端标题行”设置为“$1:$4”，然后在VBE中插入一个窗体，如图所示。
      
       双击窗体中的“打印”按钮，写入下面的代码。

1. #001  Private Sub CommandButton1_Click()
   
2. #002      Dim r As Byte
   
3. #003      Dim i As Integer
   
4. #004      Dim i1 As Integer
   
5. #005      Dim i2 As Integer
   
6. #006      Application.ScreenUpdating = False
   
7. #007      ActiveWindow.View = xlPageBreakPreview
   
8. #008      With Sheet1
   
9. #009          r = .Range("B65536").End(xlUp).Row
   
10. #010          .ResetAllPageBreaks
    
11. #011          If .HPageBreaks.Count = 0 Then
    
12. #012              .Unprotect
    
13. #013              .Cells(100, 2) = "123"
    
14. #014              i1 = .HPageBreaks(1).Location.Row
    
15. #015              .Cells(100, 2) = ""
    
16. #016              .Unprotect
    
17. #017              For i = r To i1 - 2
    
18. #018                  .Rows(r).Insert
    
19. #019              Next
    
20. #020              .Protect
    
21. #021          Else
    
22. #022              .HPageBreaks.Add Before:=.Range("B65536").End(xlUp).Offset(1, 0)
    
23. #023              i1 = .HPageBreaks(1).Location.Row - 5
    
24. #024              i2 = .HPageBreaks(.HPageBreaks.Count).Location.Row - .HPageBreaks(.HPageBreaks.Count - 1).Location.Row
    
25. #025              .Unprotect
    
26. #026              For i = 1 To i1 - i2
    
27. #027                  .HPageBreaks(.HPageBreaks.Count).Location.Offset(-1, 0).EntireRow.Insert
    
28. #028              Next
    
29. #029              .Protect
    
30. #030          End If
    
31. #031      End With
    
32. #032      ActiveWindow.View = xlNormalView
    
33. #033      Application.ScreenUpdating = True
    
34. #034      Unload Me
    
35. #035      Sheet1.PrintOut Copies:=ComboBox1.Value
    
36. #036  End Sub

复制代码

代码解析：
       打印窗体中 “打印”按钮的Click事件过程，打印“加班费计算表”。
       第7行代码，将窗口中的视图设置为分页预览。应用于Window对象的View属性返回或设置在窗口中显示的视图，设置成xlPageBreakPreview为分页预览，xlNormalView则为普通视图。
       第11行代码，判断Sheet1表是否满页。HPageBreaks属性返回 HPageBreaks集合，代表工作表上的水平分页符，如果工作表中没有水平分页符说明没有满页。
       第13行到第15行代码，在B列单元格中写入字符取得Sheet1表中第一个分页符的位置后再删除。
       第17行到第19行代码，在Sheet1表中的B列合计栏中插入一定数量的空行使其满页。
       第22行代码，如果Sheet1表的打印内容不止一页，在最后一行插入一个分页符。
       第23行代码，取得Sheet1表中满页的行数。
       第24行代码，取得Sheet1表最后一页中的行数，两者相减即能得到最后一页中需插入的行数。
       第26行到第28行代码，在Sheet1表中的B列合计栏中插入一定数量的空行使其满页。
       第32行代码，将窗口中的视图设置为普通视图。
       当使用“打印”窗体打印Sheet1表时，将自动插入一定数量的空行使其满页打印。
       步骤10，为了使用方便，需要在菜单栏中添加自定义菜单来使用各项功能，在模块中写入下面的代码。

1. #001  Sub AddNewMenu()
   
2. #002      Dim HelpMenu As CommandBarControl
   
3. #003      Dim NewMenu As CommandBarPopup
   
4. #004      With Application.CommandBars("Worksheet menu bar")
   
5. #005          .Reset
   
6. #006          Set HelpMenu = .FindControl(ID:=.Controls("帮助(&H)").ID)
   
7. #007          If HelpMenu Is Nothing Then
   
8. #008              Set NewMenu = .Controls.Add(Type:=msoControlPopup)
   
9. #009          Else
   
10. #010              Set NewMenu = .Controls.Add(Type:=msoControlPopup, Before:=HelpMenu.Index)
    
11. #011          End If
    
12. #012          With NewMenu
    
13. #013              .Caption = "加班费(&S)"
    
14. #014              With .Controls.Add(Type:=msoControlButton)
    
15. #015                  .Caption = "导入数据"
    
16. #016                  .OnAction = "ImportWages"
    
17. #017              End With
    
18. #018              With .Controls.Add(Type:=msoControlButton)
    
19. #019                  .Caption = "清除加班费"
    
20. #020                  .OnAction = "DataClear"
    
21. #021              End With
    
22. #022              With .Controls.Add(Type:=msoControlButton)
    
23. #023                  .Caption = "批量导入人员"
    
24. #024                  .OnAction = "ImportName"
    
25. #025              End With
    
26. #026              With .Controls.Add(Type:=msoControlButton)
    
27. #027                  .Caption = "计算加班费"
    
28. #028                  .OnAction = "DataCalculation"
    
29. #029              End With
    
30. #030              With .Controls.Add(Type:=msoControlButton)
    
31. #031                  .Caption = "计算高温工资"
    
32. #032                  .OnAction = "TemperatureCalculation"
    
33. #033              End With
    
34. #034              With .Controls.Add(Type:=msoControlButton)
    
35. #035                  .Caption = "加班费汇总"
    
36. #036                  .OnAction = "DataSummary"
    
37. #037              End With
    
38. #038              With .Controls.Add(Type:=msoControlButton)
    
39. #039                  .Caption = "打印加班费"
    
40. #040                  .OnAction = "HPageBreak"
    
41. #041              End With
    
42. #042          End With
    
43. #043      End With
    
44. #044      Set HelpMenu = Nothing
    
45. #045      Set NewMenu = Nothing
    
46. #046  End Sub
    
47. #047  Sub DelNewMenu()
    
48. #048      Application.CommandBars("Worksheet menu bar").Reset
    
49. #049  End Sub

复制代码

代码解析：
       AddNewMenu过程在“帮助”菜单前添加一个自定义的“加班费”菜单。
       DelNewMenu过程删除自定义的“加班费”菜单。
       为了工作簿打开时自动添加“加班费”菜单和关闭时自动删除“加班费”菜单，需要在VBE中双击ThisWorkbook写入下面的代码。

1. #001  Private Sub Workbook_Activate()
   
2. #002      Call AddNewMenu
   
3. #003  End Sub
   
4. #004  Private Sub Workbook_Deactivate()
   
5. #005      Call DelNewMenu
   
6. #006  End Sub

复制代码

关于自定义菜单请参阅技巧80 。
       保存关闭工作簿，重新打开，将在菜单栏中添加自定义的“加班费”菜单，可以方便的使用加班费计算表中的各项功能，如图所示。

hgchgchgc

太好了

forever1qaz

很好很强大！ 版主辛苦了！

nicyang86

学习楼主的分享精神

口是心非

袁版，在你的帖子：12-3        动态的数据有效性  这节中，为何我将该段代码写入thisworkbook中就无法执行呢？你的代码是写在了sheet1中，而且多了这一行：Option Explicit。请问这该如何解释？
还有就是代码中的第一行：Private Sub Worksheet_SelectionChange(ByVal Target As Range)，括号中的代码如何解释，在之后的代码中您在频繁的使用target这个单词，这点尤其不明白，呵呵，我自己知道这个单词是目标的意思，仅此而已，盼解答，多谢。