VBA常用技巧代码解析

jebsee

多谢楼主,TKS!!!!!

yuanzhuping

技巧196         职工花名册
于      在实际工作中，往往需要一个花名册用于录入职工的各项信息，在需要时可以方便的进行查找、统计以方便日常工作。
       使用Excel制作职工花名册可以方便的录入职工信息，对所录入的信息进行修改、筛选择等，制作步骤如下：
       步骤1，新建工作簿，将Sheet1工作表名称修改为“花名册”，设置成如图所示的格式。

       步骤2，在工作表的B列输入职工姓名，F列输入身份证号码，G列输入职称。
       “部门”、“职务”及“备注”从工作表中的数据有效性中选择，在VBE中双击Sheet1表，在打开的代码窗口写入下面的代码：

1. #001  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. #002      Dim r As Integer
   
3. #003      r = Sheet1.Range("B65536").End(xlUp).Row
   
4. #004      With Target
   
5. #005          If .Count = 1 And .Row > 5 And .Row <= r Then
   
6. #006              Sheet1.Unprotect
   
7. #007              Select Case .Column
   
8. #008              Case 8
   
9. #009                  With .Validation
   
10. #010                      .Delete
    
11. #011                      .Add Type:=xlValidateList, _
    
12. #012                          AlertStyle:=xlValidAlertStop, _
    
13. #013                          Operator:=xlBetween, _
    
14. #014                          Formula1:="经理室,办公室,行政科,生技科,财务科," _
    
15. #015                              & "营业部,制水车间,污水厂,其他,安装公司,退休"
    
16. #016                  End With
    
17. #017              Case 9
    
18. #018                  With .Validation
    
19. #019                      .Delete
    
20. #020                      .Add Type:=xlValidateList, _
    
21. #021                          AlertStyle:=xlValidAlertStop, _
    
22. #022                          Operator:=xlBetween, _
    
23. #023                          Formula1:="经理,副经理,支书,副支书,经理助理," _
    
24. #024                              & "中层正职,中层副职,总账会计,辅助会计," _
    
25. #025                              & "辅助会计,出纳会计,协理员,管理员,驾驶员," _
    
26. #026                              & "办事员,科档员,计量员,收费员,发货员," _
    
27. #027                              & "采购员,化验员,监察队员,班组长,拆表工," _
    
28. #028                              & "抄表工,勘估设计,预决算,校表工,换表工," _
    
29. #029                              & "机修工,电工,中控值班,制水工,安装工," _
    
30. #030                              & "外借,内退"
    
31. #031                  End With
    
32. #032              Case 10
    
33. #033                  With .Validation
    
34. #034                      .Delete
    
35. #035                      .Add Type:=xlValidateList, _
    
36. #036                          AlertStyle:=xlValidAlertStop, _
    
37. #037                          Operator:=xlBetween, _
    
38. #038                          Formula1:="在职,内退,退休"
    
39. #039                  End With
    
40. #040              End Select
    
41. #041              Sheet1.Protect
    
42. #042          End If
    
43. #043      End With
    
44. #044  End Sub

复制代码

代码解析：
       工作表的SelectionChange事件过程，当选择工作表的H、I和J列时自动生成相应的数据有效性，请参阅技巧12-1。
       “性别”、“出生年月”及“年龄”由输入的身份证号码自动生成，在Sheet1表的代码窗口写入下面的代码：

1. #001  Private Sub Worksheet_Change(ByVal Target As Range)
   
2. #002      Sheet1.Unprotect
   
3. #003      With Target
   
4. #004          If .Count = 1 And .Row > 5 And .Column = 6 Then
   
5. #005              If .Text <> "" Then
   
6. #006                  Application.EnableEvents = False
   
7. #007                  .Offset(0, -5).FormulaR1C1 = "=ROW()-5"
   
8. #008                  .Offset(0, -3) = IIf(Mid(.Text, 17, 1) Mod 2 = 0, "女", "男")
   
9. #009                  .Offset(0, -2) = Format(Mid(.Text, 7, 8), "#-00-00")
   
10. #010                  .Offset(0, -1).FormulaR1C1 = "=DATEDIF(TEXT(MID(RC[1],7,8),""#-00-00""),TODAY(),""y"")"
    
11. #011                  Application.EnableEvents = True
    
12. #012              Else
    
13. #013                  Rows(.Row) = ""
    
14. #014              End If
    
15. #015          End If
    
16. #016      End With
    
17. #017      Sheet1.Protect
    
18. #018  End Sub

复制代码

代码解析：
       工作表的Change事件过程，当输入职工身份证号码后在工作表的C、D和E列自动生成相应的“性别”、“出生年月”及“年龄”。
       第7行代码，在A列写入序号的公式。
       第8行代码，根据身份证号码的最后第二位数在C列中写入性别。
       第9行代码，根据身份证号码中的出生年月信息在D列中写入出生年月。
       第10行代码，根据身份证号码中的出生年月信息在E列中写入判断年龄的公式，因为年龄是动态的，所以只能写入公式。
       在工作表的H2、H3单元格中写入统计人员类别的公式。
       步骤3，为了方便使用，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

1. #001  Sub SectorSort()
   
2. #002      Dim r As Integer
   
3. #003      With Sheet1
   
4. #004          .Unprotect
   
5. #005          r = .Range("B65536").End(xlUp).Row
   
6. #006          If MsgBox("是否按公司部门顺序进行排序?", 36) = 6 Then
   
7. #007              .Range("A6:J" & r).Sort Key1:=.Range("H6"), _
   
8. #008                  Order1:=xlAscending, Key2:=Range("D6"), _
   
9. #009                  OrderCustom:=13
   
10. #010          End If
    
11. #011          .Protect
    
12. #012      End With
    
13. #013  End Sub

复制代码

代码解析：
       SectorSort过程对职工花名册按部门进行排序。
       第7行到第9行代码使用Sort方法对职工花名册进行排序，应用于Range对象的Sort方法对数据透视表、单元格区域或活动区域（如果指定区域仅包含一个单元格）进行排序，语法如下：
expression.Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3)
       其中Key1参数是可选的，指定第一个排序字段，本例中按部门进行排序。
       Order1参数是可选的，在Key1参数中指定的字段或区域的排序顺序。
       Key2参数是可选的，指定第二个排序字段，本例中按出生年月进行排序。
       OrderCustom参数是可选的，是从 1 开始的整数，指定了在自定义排序顺序列表中的索引号。如果省略参数，则使用常规排序。本例中在工作簿中添加了自定义的部门序列，索引号为13，如图所示。

1. #001  Sub AgeSort()
   
2. #002      Dim r As Integer
   
3. #003      Dim imsg As Integer
   
4. #004      With Sheet1
   
5. #005          r = .Range("B65536").End(xlUp).Row
   
6. #006          imsg = MsgBox("选择[是]按升降序排序,选择[否]按降序排序", 3)
   
7. #007          Select Case imsg
   
8. #008              Case 6
   
9. #009                  .Unprotect
   
10. #010                  .Range("A6:J" & r).Sort Key1:=.Range("E6"), _
    
11. #011                      Order1:=xlAscending, Key2:=.Range("D6")
    
12. #012              Case 7
    
13. #013                  .Unprotect
    
14. #014                  .Range("A6:J" & r).Sort Key1:=.Range("E6"), _
    
15. #015                      Order1:=xlDescending, Key2:=.Range("D6")
    
16. #016              End Select
    
17. #017          .Protect
    
18. #018      End With
    
19. #019  End Sub

复制代码

代码解析：
       AgeSort过程对职工花名册依据年龄进行排序。
       第10、11行代码，使用Sort方法对职工花名册按年龄进行升序排序，Sort方法的Order1参数排序顺序，可为表格所示的XlSortOrder 常量之一。
      
       第14、15行代码，使用Sort方法对职工花名册按年龄进行降序排序。

1. #001  Sub Forshow()
   
2. #002      Dim r As Integer
   
3. #003      With Sheet1
   
4. #004          .Unprotect
   
5. #005          r = .Range("B65536").End(xlUp).Row
   
6. #006          .Range("A6:J" & r).Sort Key1:=.Range("H6"), _
   
7. #007              Order1:=xlAscending, Key2:=Range("D6"), _
   
8. #008              OrderCustom:=13
   
9. #009          .Protect
   
10. #010      End With
    
11. #011      UserForm1.Show
    
12. #012  End Sub

复制代码

代码解析：
       Forshow过程对职工花名册按部门进行排序后显示按部门进行筛选的窗体。

1. #001  Sub AgeSortForshow()
   
2. #002      Dim r As Integer
   
3. #003      With Sheet1
   
4. #004          .Unprotect
   
5. #005          r = .Range("B65536").End(xlUp).Row
   
6. #006          .Range("A6:J" & r).Sort Key1:=.Range("E6"), _
   
7. #007              Order1:=xlAscending, Key2:=.Range("D6")
   
8. #008          .Protect
   
9. #009      End With
   
10. #010      UserForm2.Show
    
11. #011  End Sub

复制代码

代码解析：
       AgeSortForshow过程对职工花名册按年龄进行排序后显示按年龄进行筛选的窗体。
       步骤4，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个列表框控件和两个按钮按件，如图 所示。
      
       双击窗体，在打开的代码窗口写入下面的代码：

1. #001  Private Sub UserForm_Initialize()
   
2. #002      On Error Resume Next
   
3. #003      Dim Col As New Collection
   
4. #004      Dim rng As Range, arr
   
5. #005      Dim i As Integer
   
6. #006      For Each rng In Sheet1.Range("H6:H" & Sheet1.Range("B65536").End(xlUp).Row)
   
7. #007          If Trim(rng) <> "" Then
   
8. #008              Col.Add rng, key:=CStr(rng)
   
9. #009          End If
   
10. #010      Next
    
11. #011      ReDim arr(1 To Col.Count)
    
12. #012      For i = 1 To Col.Count
    
13. #013          arr(i) = Col(i)
    
14. #014      Next
    
15. #015      With Me.ListBox1
    
16. #016          .List = arr
    
17. #017          .ListStyle = 1
    
18. #018          .MultiSelect = 1
    
19. #019      End With
    
20. #020  End Sub

复制代码

代码解析：
       窗体的Initialize事件过程，窗体显示时将部门名称加载到窗体的列表框中。
       第6行到第14行代码，使用Add方法将工作表H列中的部门名称去除重复值。
       第15行到第19行代码，将部门名称加载到窗体的列表框并将列表框设置为显示多重选择列表的列表框。窗体显示时如图所示。
      
       双击窗体的“筛选”按钮写入下面的代码：

1. #001  Private Sub CommandButton1_Click()
   
2. #002      Dim i As Integer
   
3. #003      Dim r As Integer
   
4. #004      Dim r2 As Integer
   
5. #005      Sheet1.Unprotect
   
6. #006      Sheet2.Unprotect
   
7. #007      Application.ScreenUpdating = False
   
8. #008      r2 = Sheet2.Range("B65536").End(xlUp).Row
   
9. #009      If r2 > 5 Then
   
10. #010          With Sheet2.Range("A6:J" & r2)
    
11. #011              .ClearContents
    
12. #012              .Borders.LineStyle = xlNone
    
13. #013          End With
    
14. #014      End If
    
15. #015      r = Sheet1.Range("B65536").End(xlUp).Row
    
16. #016      For i = 0 To ListBox1.ListCount - 1
    
17. #017          If ListBox1.Selected(i) = True Then
    
18. #018              Sheet1.Range("A5:J" & r).AutoFilter Field:=8, Criteria1:="=" & ListBox1.List(i)
    
19. #019              With Sheet2
    
20. #020                  r2 = .Range("B65536").End(xlUp).Row
    
21. #021                  Sheet1.Range("A6:J" & r).SpecialCells(12).Copy
    
22. #022                  .Cells(r2 + 1, 1).PasteSpecial Paste:=xlPasteValues
    
23. #023                  Application.CutCopyMode = False
    
24. #024                  With .Range("A6:A" & .Range("B65536").End(xlUp).Row)
    
25. #025                      .FormulaR1C1 = "=ROW()-5"
    
26. #026                      .Value = .Value
    
27. #027                  End With
    
28. #028              End With
    
29. #029          End If
    
30. #030      Next
    
31. #031      With Sheet2
    
32. #032          .Range("A6:J" & .Range("B65536").End(xlUp).Row).Borders.LineStyle = xlContinuous
    
33. #033          Application.Goto Reference:=.Range("A2"), Scroll:=True
    
34. #034          .Protect
    
35. #035      End With
    
36. #036      Sheet1.Range("A1:J" & r).AutoFilter
    
37. #037      Sheet1.Protect
    
38. #038      Unload Me
    
39. #039      Application.ScreenUpdating = True
    
40. #040  End Sub

复制代码

代码解析：
       “筛选”按钮的单击过程，将窗体列表框中所选中的部门数据筛选后复制到工作表中。
       第10行到第12行代码，删除工作表中原有的数据，去除边框线。
       第16行到第29行代码，将窗体列表框中所选中的部门数据进行筛选后依次复制到工作表中。
       其中第18行代码使用AutoFilter方法进行筛选。应用于Range对象的AutoFilter方法使用“自动筛选”筛选出一个列表，语法如下：
expression.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown)
       参数Field是可选的，相对于作为筛选基准字段（从列表左侧开始，最左侧的字段为第一个字段）的偏移量。本例中设置为8，即指定工作表中的H列进行筛选。
       参数Criteria1是可选的，筛选条件。本例中设置为窗体列表框中所选中的部门名称。
       第32行代码，将筛选后的数据画上边框线。
       步骤5，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件和两个组合框按件，如图 所示。
      
       双击窗体，在打开的代码窗口写入下面的代码：

1. #001  Private Sub UserForm_Initialize()
   
2. #002      On Error Resume Next
   
3. #003      Dim Col As New Collection
   
4. #004      Dim rng As Range, arr
   
5. #005      Dim i As Integer
   
6. #006      For Each rng In Sheet1.Range("E6:E" & Sheet1.Range("B65536").End(xlUp).Row)
   
7. #007          Col.Add rng, key:=CStr(rng)
   
8. #008      Next
   
9. #009      ReDim arr(1 To Col.Count)
   
10. #010      For i = 1 To Col.Count
    
11. #011          arr(i) = Col(i)
    
12. #012      Next
    
13. #013      Me.ComboBox1.List = arr
    
14. #014      Me.ComboBox2.List = arr
    
15. #015  End Sub

复制代码

代码解析：
       窗体的Initialize事件过程，窗体显示时将所有的年龄加载到窗体的组合框中。
       第6行到第12行代码，使用Add方法将工作表E列中的年龄去除重复值。
       第13、14行代码，将年龄加载到窗体的组合框中。
       双击窗体的“筛选”按钮写入下面的代码：

1. #001  Private Sub CommandButton1_Click()
   
2. #002      Dim r As Integer
   
3. #003      Dim r2 As Integer
   
4. #004      Dim dInput As Double
   
5. #005      If Me.ComboBox1.Value = "" Or Me.ComboBox2.Value = "" Then
   
6. #006          MsgBox "请选择需要筛选的年龄!"
   
7. #007          Exit Sub
   
8. #008      End If
   
9. #009      If Me.ComboBox1.Value > Me.ComboBox2.Value Then
   
10. #010          MsgBox "开始年龄不能等结束年龄,请重新选择!"
    
11. #011          Me.ComboBox1.ListIndex = -1
    
12. #012          Me.ComboBox2.ListIndex = -1
    
13. #013          Exit Sub
    
14. #014      End If
    
15. #015      Application.ScreenUpdating = False
    
16. #016      With Sheet1
    
17. #017          r = .Range("B65536").End(xlUp).Row
    
18. #018          .Unprotect
    
19. #019          .Range("A5:J" & r).AutoFilter Field:=5, Criteria1:=">=" & Me.ComboBox1.Value, Operator:=xlAnd, Criteria2:="<=" & Me.ComboBox2.Value
    
20. #020          With Sheet2
    
21. #021              .Unprotect
    
22. #022              r2 = .Range("B65536").End(xlUp).Row
    
23. #023              If r2 > 5 Then
    
24. #024                  With .Range("A6:J" & r2)
    
25. #025                      .ClearContents
    
26. #026                      .Borders.LineStyle = xlNone
    
27. #027                  End With
    
28. #028              End If
    
29. #029              Sheet1.Range("A6:J" & r).SpecialCells(12).Copy
    
30. #030              .Cells(6, 1).PasteSpecial Paste:=xlPasteValues
    
31. #031              Application.CutCopyMode = False
    
32. #032              With .Range("A6:A" & .Range("B65536").End(xlUp).Row)
    
33. #033                  .FormulaR1C1 = "=ROW()-5"
    
34. #034                  .Value = .Value
    
35. #035              End With
    
36. #036                  .Range("A6:J" & .Range("B65536").End(xlUp).Row).Borders.LineStyle = xlContinuous
    
37. #037              Unload Me
    
38. #038              Application.Goto Reference:=.Range("A3"), Scroll:=True
    
39. #039              .Protect
    
40. #040          End With
    
41. #041          .Range("A1:J" & r).AutoFilter
    
42. #042          .Protect
    
43. #043      End With
    
44. #044      Application.ScreenUpdating = True
    
45. #045  End Sub

复制代码

代码解析：
       “筛选”按钮的单击过程，将根据窗体组合框中所选中的年龄进行筛选后的数据复制到工作表中。
       第5行到第8行代码，年龄不能为空。
       第9行到第14行代码，开始年龄不能小于结束年龄。
       第19行代码，使用AutoFilter方法进行筛选。将第一个筛选条件设置为开始年龄，第二个筛选条件设置为结束年龄。
       第23行到第28行代码，删除工作表中原有的数据，去除边框线。
       第29行到第35行代码，将筛选后的数据复制到工作表中。
       第36行代码，将筛选后的数据画上边框线。
       步骤6，为了方便使用，在工作表中单击菜单“视图”→“工具栏”→“窗体”，添加两个框架，在每个框架中添加两个单选框，将模块中的宏指定给单选框，如图所示。

       步骤7，为了保存筛选后的数据，将工作簿的Sheet2表重命名为“筛选数据”，并设置成如图所示的格式。

       步骤8，选择“花名册”表的B、F和G列第6行以下区域，去除其锁定属性后保护工作表，对“筛选数据”表进行保护。在工作表中单击菜单“工具”→“选项”，在显示的选项对话框的视图页中去除工作表的行号列标及网格线后保存关闭工作簿。
打开工作簿，在“花名册”表中输入职工姓名、身份证号及职称后“花名册”表如图所示。

       对表中数据进行筛选，比如按部门中的“生技科”进行筛选后“筛选数据”表中如图所示。

ni57

楼主真伟人也，高山仰止

mikeeguo

非常感谢分享

pujizhongxue

太多太好，有点眼花缭乱了

wingbake

china_rocket

谢谢，太多了好难下载

ssp584521

谢谢楼主！

收菊花的人

真是好帖啊，期待WORD文档的出现！

飞飞阳

谢谢