使用Excel VBA高效审计钉钉打卡记录，快速识别代打卡行为

近期，我们在某项目的考勤核查中发现，存在员工通过他人手机登录钉钉进行虚假定位打卡的违规情况。经深入调查，该问题已得到证实。

在处理相关违纪员工的同时，我们意识到集团拥有7000余名在职员工，此类作弊行为存在的风险较高。因此，决定对全部员工的原始打卡记录展开全面审计。

每月7000名员工产生的打卡记录接近20万条，数据量庞大，人工核对几乎不可行。通过分析代打卡行为的业务逻辑，我们发现：如果单一设备编码（手机硬件标识）对应多个不同的员工账号，即可判定存在代打卡嫌疑。

基于这一规律，开发了以下Excel VBA解决方案，实现快速、自动化的审计流程：

Sub FindMultiUserDevices()
    ' 声明变量
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim dict As Object ' 用于存储设备号和对应的员工集合
    Dim lastRow As Long, i As Long
    Dim deviceID As String, employeeName As String
    Dim key As Variant, empKey As Variant
    Dim outputRow As Long
    Dim nameList As String

    ' 设置源数据工作表 (假设数据在原始记录)
    On Error Resume Next
    Set wsSource = ThisWorkbook.Worksheets("原始记录")
    On Error GoTo 0

    If wsSource Is Nothing Then
        MsgBox "找不到工作表 '原始记录'，请修改代码中的工作表名称。", vbExclamation
        Exit Sub
    End If

    ' 创建或清空结果工作表
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("异常设备报告").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    Set wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    wsResult.Name = "异常设备报告"

    ' 在结果表创建标题
    With wsResult
        .Range("A1").Value = "设备编号"
        .Range("B1").Value = "使用员工数量"
        .Range("C1").Value = "使用员工名单"
        .Range("A1:C1").Font.Bold = True
        .Columns("A:C").AutoFit
    End With

    outputRow = 2 ' 从第2行开始输出结果

    ' 创建字典对象来存储数据
    Set dict = CreateObject("Scripting.Dictionary")

    ' 找出源数据的最后一行 (使用P列确定行数)
    lastRow = wsSource.Cells(wsSource.Rows.Count, "P").End(xlUp).Row

    ' 检查是否有数据
    If lastRow < 2 Then
        wsResult.Cells(2, 1).Value = "源数据表中没有找到有效数据。"
        wsResult.Columns("A:C").AutoFit
        wsResult.Activate
        Exit Sub
    End If

    ' 遍历所有数据行 (假设第1行是标题，从第2行开始)
    For i = 2 To lastRow
        On Error Resume Next ' 防止类型转换错误
        deviceID = Trim(CStr(wsSource.Cells(i, "P").Value)) ' P列是设备号
        employeeName = Trim(CStr(wsSource.Cells(i, "A").Value)) ' A列是员工姓名
        On Error GoTo 0

        ' 跳过空设备号或空姓名的行
        If deviceID = "" Or employeeName = "" Then GoTo NextRow

        ' 如果字典中没有这个设备号，则添加一个新集合
        If Not dict.Exists(deviceID) Then
            dict.Add deviceID, CreateObject("Scripting.Dictionary")
        End If

        ' 将员工姓名添加到该设备号对应的集合中
        If Not dict(deviceID).Exists(employeeName) Then
            dict(deviceID).Add employeeName, Nothing
        End If

NextRow:
    Next i

    ' 遍历字典，找出使用员工数 > 1 的设备
    For Each key In dict.Keys
        If dict(key).Count > 1 Then
            ' 输出到结果表
            wsResult.Cells(outputRow, 1).Value = key ' 设备号
            wsResult.Cells(outputRow, 2).Value = dict(key).Count ' 员工数量

            ' 将员工姓名集合连接成一个字符串，用逗号隔开
            nameList = ""
            For Each empKey In dict(key).Keys
                nameList = nameList & empKey & ", "
            Next empKey

            ' 去掉最后一个逗号和空格
            If Len(nameList) > 0 Then
                nameList = Left(nameList, Len(nameList) - 2)
            End If

            wsResult.Cells(outputRow, 3).Value = nameList ' 员工名单
            outputRow = outputRow + 1
        End If
    Next key

    ' 如果没有找到异常设备，提示用户
    If outputRow = 2 Then
        wsResult.Cells(2, 1).Value = "未发现一个设备对应多个员工的情况。"
    Else
        ' 对结果表进行排序（按员工数量降序）
        With wsResult
            If outputRow > 2 Then
                .Range("A1:C" & outputRow - 1).Sort Key1:=.Range("B2"), Order1:=xlDescending, Header:=xlYes
            End If
        End With
    End If

    ' 自动调整列宽
    wsResult.Columns("A:C").AutoFit
    wsResult.Activate ' 切换到结果工作表

    MsgBox "分析完成！共找到 " & (outputRow - 2) & " 个异常设备。结果已输出到工作表【异常设备报告】。", vbInformation
End Sub

实际运行结果如下图：