Sub FindMultiUserDevicesWithCount()
    ' 声明变量
    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("D1").Value = "设备持有人"
        .Range("E1").Value = "代打卡员工"
        .Range("A1:E1").Font.Bold = True
        .Columns("A:E").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:E").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

        ' 如果该设备号的字典中没有这个员工，则添加并初始化计数为1
        If Not dict(deviceID).Exists(employeeName) Then
            dict(deviceID).Add employeeName, 1
        Else
            ' 如果已存在，则计数加1
            dict(deviceID)(employeeName) = dict(deviceID)(employeeName) + 1
        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 & "(" & dict(key)(empKey) & "次), "
            Next empKey

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

            wsResult.Cells(outputRow, 3).Value = nameList ' 员工名单及打卡次数

            ' 新增功能：识别设备持有人和代打卡员工
            Dim maxCount As Long
            Dim holder As String
            Dim proxyEmployees As String

            ' 找出打卡次数最多的员工
            maxCount = 0
            holder = ""
            For Each empKey In dict(key).Keys
                If dict(key)(empKey) > maxCount Then
                    maxCount = dict(key)(empKey)
                    holder = empKey
                End If
            Next

            ' 构建代打卡员工名单（包含打卡次数）
            proxyEmployees = ""
            For Each empKey In dict(key).Keys
                If empKey <> holder Then
                    proxyEmployees = proxyEmployees & empKey & "(" & dict(key)(empKey) & "次), "
                End If
            Next

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

            ' 写入持有人和代打卡员工信息
            wsResult.Cells(outputRow, 4).Value = holder & "(" & maxCount & "次)"
            wsResult.Cells(outputRow, 5).Value = proxyEmployees

            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:E" & outputRow - 1).Sort Key1:=.Range("B2"), Order1:=xlDescending, Header:=xlYes
            End If
        End With
    End If

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

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

主要功能：

• 数据源处理：从名为“原始记录”的工作表中读取数据，其中设备编号位于P列，员工姓名位于A列。
• 数据统计：使用字典对象高效地统计每个设备编号对应的员工及其打卡次数。
• 报告生成：创建一个名为“异常设备报告”的新工作表，列出所有异常设备（即被多个员工使用的设备），包括以下信息：
• 设备编号：设备的唯一标识。
• 使用员工数量：使用该设备的员工总数。
• 使用员工名单及打卡次数：列出所有使用该设备的员工姓名及其打卡次数（例如：张三(5次), 李四(3次)）。
• 设备持有人：打卡次数最多的员工（被视为主要使用者）。
• 代打卡员工：其他使用该设备的员工（可能涉及代打卡行为）。
• 排序和格式化：报告按员工数量降序排序，并自动调整列宽以便阅读。
• 用户反馈：运行完成后，显示消息框提示找到的异常设备数量。

适用场景：

• 企业考勤系统分析，检测异常打卡行为。
• 设备使用审计，确保设备分配合规。
• 人力资源或安全管理，防止代打卡或未授权设备使用。

如何使用：

1. 确保Excel工作簿中有一个名为“原始记录”的工作表，且包含员工姓名（A列）和设备编号（P列）数据。
2. 在Excel中运行此宏（通过VBA编辑器或按钮触发）。
3. 宏将自动生成“异常设备报告”工作表，并提供分析结果。

Sub FindMultiUserDevicesWithCount()
    ' 声明变量
    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

        ' 如果该设备号的字典中没有这个员工，则添加并初始化计数为1
        If Not dict(deviceID).Exists(employeeName) Then
            dict(deviceID).Add employeeName, 1
        Else
            ' 如果已存在，则计数加1
            dict(deviceID)(employeeName) = dict(deviceID)(employeeName) + 1
        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 & "(" & dict(key)(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

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

在处理相关违纪员工的同时，我们意识到集团拥有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

实际运行结果如下图：