多Excel文件用户登录时长统计VBA代码优化求助

原代码问题诊断 #

原代码存在以下关键问题导致无有效数据输出：

• 变量未声明（如sourceFile、loginTime等），运行时易触发错误
• 表头写入后立即执行Cells.Clear，导致表头被清空
• 文件遍历逻辑错误，路径拼接不规范且循环变量更新错误
• 连续登录记录的处理逻辑失效，prevAction未更新
• 缺少月度累计时长的计算逻辑
• 工作簿关闭时使用了未定义的变量wbSource
• 每次处理新文件都会清空目标表，最终仅保留最后一个文件的数据

优化后的完整代码 #

Option Explicit

Sub ExtractDataFromMultipleFiles()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim folderPath As String
    Dim sourceWorkbook As Workbook
    Dim srcSheet As Worksheet, destWs As Worksheet
    Dim lastRow As Long, i As Long, destLastRow As Long
    Dim loginTime As Date, logoutTime As Date
    Dim totalTime As Double
    Dim loginID As String, userName As String, prevAction As String
    Dim monthKey As String
    ' 字典用于存储用户每月累计时长
    Dim monthlyTotalDict As Object
    Set monthlyTotalDict = CreateObject("Scripting.Dictionary")
    
    ' 设置文件夹路径（Mac格式，Windows请改为类似"C:\Users\XXX\Desktop\"）
    folderPath = "/Users/kabu/Desktop/"
    If Right(folderPath, 1) <> "/" Then folderPath = folderPath & "/"
    
    ' 初始化目标工作表
    Set destWs = ThisWorkbook.Sheets("RESULT")
    ' 清空现有数据并写入表头
    destWs.Cells.Clear
    With destWs.Range("A1:E1")
        .Value = Array("DATE", "LoginID", "Name", "TotalTime(per user)", "TOTAL_TIME(per month)")
        .Font.Bold = True
    End With
    destLastRow = 2 ' 从第二行开始写入数据
    
    ' 遍历文件夹中的所有Excel文件
    Dim sourceFile As String
    sourceFile = Dir(folderPath & "*.xlsx")
    Do While sourceFile <> ""
        Set sourceWorkbook = Workbooks.Open(folderPath & sourceFile, ReadOnly:=True)
        Set srcSheet = sourceWorkbook.Sheets(1)
        
        lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
        prevAction = "" ' 重置上一个动作标记
        
        For i = 2 To lastRow
            ' 确保时间戳为日期格式
            If Not IsDate(srcSheet.Cells(i, "A").Value) Then
                ' 尝试转换文本为日期，根据实际格式调整转换逻辑
                On Error Resume Next
                srcSheet.Cells(i, "A").Value = CDate(srcSheet.Cells(i, "A").Value)
                On Error GoTo 0
            End If
            
            loginID = srcSheet.Cells(i, "B").Value
            userName = srcSheet.Cells(i, "C").Value
            
            Select Case UCase(srcSheet.Cells(i, "D").Value)
                Case "GET", "LOGIN"
                    ' 处理连续登录：保留最早的登录时间
                    If UCase(prevAction) = "GET" Or UCase(prevAction) = "LOGIN" Then
                        loginTime = Application.Min(loginTime, srcSheet.Cells(i, "A").Value)
                    Else
                        loginTime = srcSheet.Cells(i, "A").Value
                    End If
                    prevAction = srcSheet.Cells(i, "D").Value
                
                Case "RELEASE", "LOGOUT"
                    If UCase(prevAction) = "GET" Or UCase(prevAction) = "LOGIN" Then
                        logoutTime = srcSheet.Cells(i, "A").Value
                        totalTime = logoutTime - loginTime
                        
                        ' 计算月度key：LoginID_YYYY-MM
                        monthKey = loginID & "_" & Format(logoutTime, "yyyy-mm")
                        
                        ' 更新字典中的月度累计时长
                        If monthlyTotalDict.Exists(monthKey) Then
                            monthlyTotalDict(monthKey) = monthlyTotalDict(monthKey) + totalTime
                        Else
                            monthlyTotalDict(monthKey) = totalTime
                        End If
                        
                        ' 写入单次记录到目标表
                        destWs.Cells(destLastRow, "A").Value = logoutTime
                        destWs.Cells(destLastRow, "B").Value = loginID
                        destWs.Cells(destLastRow, "C").Value = userName
                        destWs.Cells(destLastRow, "D").Value = totalTime
                        destWs.Cells(destLastRow, "E").Value = monthlyTotalDict(monthKey)
                        
                        destLastRow = destLastRow + 1
                        prevAction = srcSheet.Cells(i, "D").Value
                    End If
            End Select
        Next i
        
        sourceWorkbook.Close SaveChanges:=False
        sourceFile = Dir ' 获取下一个文件
    Loop
    
    ' 设置时间格式
    destWs.Columns("A").NumberFormat = "yyyy-mm-dd hh:mm:ss"
    destWs.Columns("D:E").NumberFormat = "[h]:mm:ss" ' 显示超过24小时的时长
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "数据提取完成"
End Sub

关键修改说明 #

• 强制变量声明：新增Option Explicit，避免未定义变量导致的运行错误
• 目标表初始化优化：先清空数据再写入表头，确保表头保留
• 文件遍历修复：规范路径拼接，修复循环变量更新逻辑，确保遍历所有文件
• 连续登录处理：正确更新prevAction，保留最早登录时间匹配后续登出记录
• 月度累计逻辑：使用字典monthlyTotalDict存储每个用户每月的累计时长，实时更新目标表E列
• 时间格式处理：自动转换非日期格式的时间戳，设置输出列的时间/时长格式
• 效率优化：关闭屏幕更新和自动计算，减少工作表交互次数
• 错误修正：修复工作簿关闭的变量错误，添加只读打开源文件避免锁定

内容的提问来源于stack exchange，提问作者V_JK