# Excel VBA 审计钉钉原始打卡记录(优化版代码)

- 连结：https://blog.guohao.asia/excel-vba-%e5%ae%a1%e8%ae%a1%e9%92%89%e9%92%89%e5%8e%9f%e5%a7%8b%e6%89%93%e5%8d%a1%e8%ae%b0%e5%bd%95%e4%bc%98%e5%8c%96%e7%89%88%e4%bb%a3%e7%a0%81.html
- 发布时间：2025-08-29T11:45:14+08:00
- 作者：null

来自 AI 助手的总结

该 VBA 代码用于分析 Excel 数据，找出被多个员工使用的设备并生成异常报告。

中文   英文   韩语   日语

    ```language-default
    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
    ```