Excel VBA高效办公应用-第九章-VBA文秘办公技巧-Part2（查找同名同姓的员工）

改写了一下示例中的代码，6行变一行。

代码如下：

Option Explicit
Sub tongm()
Application.ScreenUpdating = False
    '关闭执行程序时发生的屏幕更新现象,加快运行速度
Dim i As Integer, Inum As Integer
Dim k As Integer '定义变量k为"同名员工"工作表的行变量
    k = 2 '初始行为第一行
    '计算"同名员工"工作表里有员工资料的数据的总行数
    Inum = Sheets("员工资料").[B3].CurrentRegion.Rows.Count
    '循环比较，看是否有学生重名
    For i = 3 To Inum
        '用CountIf比较是否总记录里是否有和当前姓名相同的
        If Application.WorksheetFunction.CountIf([b3:b12], Cells(i, 2)) > 1 Then
        '如果相同"同名员工"往下移一行
            k = k + 1
            '将"员工资料"当前行的数据一一复制到同名员工中
'           Sheets("同名员工").Cells(k, 1) = Sheets("员工资料").Cells(i, 1)
'           Sheets("同名员工").Cells(k, 2) = Sheets("员工资料").Cells(i, 2)
'           Sheets("同名员工").Cells(k, 3) = Sheets("员工资料").Cells(i, 3)
'           Sheets("同名员工").Cells(k, 4) = Sheets("员工资料").Cells(i, 4)
'           Sheets("同名员工").Cells(k, 5) = Sheets("员工资料").Cells(i, 5)
'           Sheets("同名员工").Cells(k, 6) = Sheets("员工资料").Cells(i, 6)
            Sheets("同名员工").Range("A" & k & ":F" & k).Value = Sheets("员工资料").Range("A" & i & ":F" & i).Value
        End If
   Next i
    '将同名的同学放在一起
    Sheets("同名员工").Activate '首先激活"同名员工"
    '以姓名为关键字进行排序,这样同名的员工就在一起了
    Range("A3:F10").Sort key1:=Range("B3")
    '选择表示日期的单元
    Range(Cells(3, 4), Cells(k, 4)).Select
    '设置单元格的格式为日期格式
    Selection.NumberFormatLocal = "yyyy-m-d"
    '使所有项目居中表示
    Cells.Select
    Selection.HorizontalAlignment = xlCenter
    Selection.VerticalAlignment = xlCenter
   '如果没有重名，给出提示
    If k = 1 Then
        MsgBox "无重名员工"
    End If
End Sub