标签： excelVBA

使用ExcelVBA审计钉钉原始打卡记录(代码优化)

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次)）。
设备持有人：打卡次数最多的员工（被视为主要使用者）。
代打卡员工：其他使用该设备的员工（可能涉及代打卡行为）。
排序和格式化：报告按员工数量降序排序，并自动调整列宽以便阅读。
用户反馈：运行完成后，显示消息框提示找到的异常设备数量。

适用场景：

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

如何使用：

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

2025年8月30日

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

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

2025年8月29日

使用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

实际运行结果如下图：

2025年8月28日

根据类别列数据，将不同类别拆分成独立excel文件

Sub 根据类别列数据，将不同类别拆分成独立excel文件()
    Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&, Mystr$
    Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&, mypath$
    Dim Cll As Range, sht As Worksheet '第一部分，用户选择保存分表工作簿的路径。
        With Application.FileDialog(msoFileDialogFolderPicker)
        '选择保存工作薄的文件路径
            .AllowMultiSelect = False
            '不允许多选
            If .Show Then
               mypath = .SelectedItems(1)
                '读取选择的文件路径
              Else
             Exit Sub
'如果没有选择保存路径，则退出程序
              End If
        End With

        If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
        ' '
        '第二部分遍历总表数据，通过字典将指定字段的不同明细行过滤保存
            Set d = CreateObject("scripting.dictionary") 'set字典
            Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
            '用户选择的拆分依据列
            tCol = Rg.Column '取拆分依据列列标
            tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
            '用户设置总表的标题行数
            If tRow < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
                Set Rng = ActiveSheet.UsedRange '总表的数据区域
                Set Cll = ActiveSheet.Cells '用于在分表粘贴和总表同样行高列宽的数据格式
                arr = Rng '数据范围装入数组arr
                tCol = tCol - Rng.Column + 1 '计算依据列在数组中的位置
                aCol = UBound(arr, 2) '数据源的列数
            For i = tRow + 1 To UBound(arr) '遍历数组arr
                If arr(i, tCol) = "" Then arr(i, tCol) = "单元格空白"
                    Mystr = arr(i, tCol) '统一转换为字符串格式
                    If Not d.exists(Mystr) Then
                        d(Mystr) = i '字典中不存在关键词则将行号装入字典
                    Else
                        d(Mystr) = d(Mystr) & "," & i '如果存在则合并行号，以逗号间隔
            End If
        Next
' '
'第三部分遍历字典取出分表数据明细，建立不同工作簿保存数据。
    Application.ScreenUpdating = False '关闭屏幕刷新
    Application.DisplayAlerts = False '关闭系统警告信息
    kr = d.keys '字典的key集
    For i = 0 To UBound(kr) '遍历字典key值
        If kr(i) <> "" Then '如果key不为空
            r = Split(d(kr(i)), ",") '取出item里储存的行号
            ReDim brr(1 To UBound(r) + 1, 1 To aCol) '声明放置结果的数组brr
            k = 0
            For x = 0 To UBound(r)
                k = k + 1'累加记录行数
                For j = 1 To aCol '遍历读取列
                    brr(k, j) = arr(r(x), j)
                 Next
             Next
                With Workbooks.Add
            '新建一个工作簿
                    With .Sheets(1).[a1]
                        Cll.Copy '复制粘贴总表的单元格格式
                        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Cells.NumberFormat = "@" '设置文本格式，防止文本值变形
                        If tRow > 0 Then .Resize(tRow, aCol) = arr '放标题行
                            .Offset(tRow, 0).Resize(k, aCol) = brr '放置数据区域
                            .Select'激活A1单元格
                    End With
        .SaveAs mypath & kr(i), xlWorkbookDefault '保存工作簿
        .Close True '关闭工作簿
                End With
        End If
    Next
'收尾巴。
Set d = Nothing '释放字典
Erase arr: Erase brr '释放数组
MsgBox "处理完成。", , "提醒"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True '恢复显示系统警告和消息
End Sub

2022年9月1日