Excel VBA合并两张考勤表输出异常，求代码排查

问题说明 #

我在Sheet1（签到表）和Sheet2（签退表）分别存储员工签到、签退记录，想通过VBA合并成一张表并统计每位员工每日工作时长，但运行代码后结果不符合预期：

• 签到表结构：日期、员工ID、签到时间，示例数据包含员工1001、1002在2024/5/1的签到记录
• 签退表结构：日期、员工ID、签退时间，示例数据包含对应员工同日的签退记录
• 预期输出：按「员工ID+日期」分组，展示当日所有签到签退记录，计算总工时（如员工1001当日总工时9.5小时）
• 实际输出：签到签退时间匹配混乱，总工时计算错误，部分单元格显示MISSING_PUNCH或无效值

原VBA代码 #

Sub CombineAttendanceData()
Dim wsA As Worksheet, wsB As Worksheet, wsResult As Worksheet
Dim LastRowA As Long, LastRowB As Long
Dim EmployeeData As Object
Dim EmployeeID As Long
Dim CurrentRowA As Long, CurrentRowB As Long
Dim MaxPunches As Long
Dim i As Long, j As Long
Dim TotalHours As Double

' Set your worksheets by index
Set wsA = ThisWorkbook.Sheets(1)
Set wsB = ThisWorkbook.Sheets(2)

' Create a new worksheet for the result
Set wsResult = ThisWorkbook.Sheets.Add
wsResult.Name = "Attendance Result"

' Initialize the data structure
Set EmployeeData = CreateObject("Scripting.Dictionary")

' Find the last row in both sheets
LastRowA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
LastRowB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row

' Loop through Sheet A to gather punch-in data
For CurrentRowA = 2 To LastRowA ' Assuming headers in row 1
EmployeeID = wsA.Cells(CurrentRowA, 2).Value
If Not EmployeeData.Exists(EmployeeID) Then
Set EmployeeData(EmployeeID) = CreateObject("System.Collections.ArrayList")
End If
EmployeeData(EmployeeID).Add Array(wsA.Cells(CurrentRowA, 1).Value, wsA.Cells(CurrentRowA, 3).Value)
Next CurrentRowA

' Loop through Sheet B to gather punch-out data
For CurrentRowB = 2 To LastRowB
EmployeeID = wsB.Cells(CurrentRowB, 2).Value
If EmployeeData.Exists(EmployeeID) Then
EmployeeData(EmployeeID)(EmployeeData(EmployeeID).Count - 1) = _
Array(EmployeeData(EmployeeID)(EmployeeData(EmployeeID).Count - 1)(0), _
EmployeeData(EmployeeID)(EmployeeData(EmployeeID).Count - 1)(1), _
wsB.Cells(CurrentRowB, 3).Value)
End If
Next CurrentRowB

' Find the maximum number of punches
For Each Key In EmployeeData.Keys
If EmployeeData(Key).Count > MaxPunches Then
MaxPunches = EmployeeData(Key).Count
End If
Next Key

' Add headers to the result worksheet

wsResult.Cells(1, 1).Value = "Employee ID"
wsResult.Cells(1, 2).Value = "Date"
For i = 1 To MaxPunches
wsResult.Cells(1, 2 * i + 1).Value = "Check In " & i
wsResult.Cells(1, 2 * i + 2).Value = "Check Out " & i
Next i
wsResult.Cells(1, 2 * MaxPunches + 3).Value = "Total Hours"

' Set the format for check-in and check-out columns
For i = 1 To MaxPunches
wsResult.Cells(1, 2 * i + 1).NumberFormat = "h:mm:ss"
wsResult.Cells(1, 2 * i + 2).NumberFormat = "h:mm:ss"
Next i


' keyword for missing data
Dim missingKeyword As String
missingKeyword = "MISSING_PUNCH"

' Populate the result worksheet
CurrentRowB = 2
For Each Key In EmployeeData.Keys
For Each punch In EmployeeData(Key)
wsResult.Cells(CurrentRowB, 1).Value = Key
wsResult.Cells(CurrentRowB, 2).Value = punch(0)
Dim totalCheckIn As Double
Dim totalCheckOut As Double

For i = 1 To MaxPunches
If i <= EmployeeData(Key).Count Then
Dim subarray As Variant
If i <= UBound(punch) Then
subarray = punch(i)
If IsArray(subarray) Then
If UBound(subarray) >= 1 Then
' Check if the value can be interpreted as a date and time
If IsDate(subarray(1)) Then
wsResult.Cells(CurrentRowB, 2 * i + 1).Value = TimeValue(subarray(1))
Else
' Replace missing or invalid data with the keyword
wsResult.Cells(CurrentRowB, 2 * i + 1).Value = missingKeyword
End If
Else
' Replace missing or invalid data with the keyword
wsResult.Cells(CurrentRowB, 2 * i + 1).Value = missingKeyword
End If
If UBound(subarray) >= 2 Then
' Check if the value can be interpreted as a date and time
If IsDate(subarray(2)) Then
wsResult.Cells(CurrentRowB, 2 * i + 2).Value = TimeValue(subarray(2))
Else
' Replace missing or invalid data with the keyword
wsResult.Cells(CurrentRowB, 2 * i + 2).Value = missingKeyword
End If
Else
' Replace missing or invalid data with the keyword
wsResult.Cells(CurrentRowB, 2 * i + 2).Value = missingKeyword
End If
Else
' If subarray is not an array, check if it can be interpreted as a date and time
If IsDate(subarray) Then
wsResult.Cells(CurrentRowB, 2 * i + 1).Value = TimeValue(subarray)
Else
' Replace missing or invalid data with the keyword
wsResult.Cells(CurrentRowB, 2 * i + 1).Value = missingKeyword
End If
End If
Else
' Replace missing data with the keyword
wsResult.Cells(CurrentRowB, 2 * i + 1).Value = missingKeyword
wsResult.Cells(CurrentRowB, 2 * i + 2).Value = missingKeyword
End If
End If
' Calculate Total Hours

On Error Resume Next

If Not IsEmpty(wsResult.Cells(CurrentRowB, 2 * i + 1).Value) Then
totalCheckIn = totalCheckIn + CDbl(wsResult.Cells(CurrentRowB, 2 * i + 1).Value)
End If
If Not IsEmpty(wsResult.Cells(CurrentRowB, 2 * i + 2).Value) Then
totalCheckOut = totalCheckOut + CDbl(wsResult.Cells(CurrentRowB, 2 * i + 2).Value)
End If
Next i
TotalHours = (totalCheckOut - totalCheckIn) * 24 ' Convert to hours
wsResult.Cells(CurrentRowB, 2 * MaxPunches + 3).Value = TotalHours
TotalHours = 0

CurrentRowB = CurrentRowB + 1
Next punch
Next Key


MsgBox "Done"

End Sub

问题根源 #

1. 匹配逻辑错误：仅用员工ID作为字典键，未按「员工ID+日期」分组，导致不同日期的签到签退被错误关联，同一员工同日多次签到签退时匹配错位。
2. 数据结构不合理：用ArrayList存储员工所有签到记录，无法区分日期，后续匹配签退时无法精准对应。
3. 结果填充逻辑混乱：遍历最大签到次数时，错误地从单条签到记录数组中取索引i的元素，导致索引越界或取值错误。
4. 工时计算逻辑瑕疵：虽数学结果正确，但将所有签到、签退时间分别相加再相减的逻辑不符合实际考勤规则，且遇到缺失数据时容易出错。

修复后的VBA代码 #

Sub CombineAttendanceData_Fixed()
    Dim wsCheckIn As Worksheet, wsCheckOut As Worksheet, wsResult As Worksheet
    Dim lastRowIn As Long, lastRowOut As Long
    Dim empDict As Object, dateDict As Object
    Dim empID As Long, attDate As Date
    Dim i As Long, j As Long, resultRow As Long
    Dim maxPunches As Integer, totalHours As Double
    Dim missingPunch As String
    
    ' 初始化工作表
    Set wsCheckIn = ThisWorkbook.Sheets(1)
    Set wsCheckOut = ThisWorkbook.Sheets(2)
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("Attendance Result")
    If Err.Number <> 0 Then
        Set wsResult = ThisWorkbook.Sheets.Add
        wsResult.Name = "Attendance Result"
    End If
    On Error GoTo 0
    wsResult.Cells.Clear
    
    ' 初始化数据结构：外层字典(员工ID) -> 内层字典(日期) -> 签到签退时间集合
    Set empDict = CreateObject("Scripting.Dictionary")
    missingPunch = "MISSING_PUNCH"
    
    ' 读取签到数据
    lastRowIn = wsCheckIn.Cells(wsCheckIn.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRowIn
        attDate = wsCheckIn.Cells(i, 1).Value
        empID = wsCheckIn.Cells(i, 2).Value
        inTime = wsCheckIn.Cells(i, 3).Value
        
        If Not empDict.Exists(empID) Then
            Set empDict(empID) = CreateObject("Scripting.Dictionary")
        End If
        If Not empDict(empID).Exists(attDate) Then
            Set empDict(empID)(attDate) = CreateObject("System.Collections.ArrayList")
        End If
        ' 存储签到时间，用数组标记类型：(时间, 类型：0=签到)
        empDict(empID)(attDate).Add Array(inTime, 0)
    Next i
    
    ' 读取签退数据并匹配
    lastRowOut = wsCheckOut.Cells(wsCheckOut.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRowOut
        attDate = wsCheckOut.Cells(i, 1).Value
        empID = wsCheckOut.Cells(i, 2).Value
        outTime = wsCheckOut.Cells(i, 3).Value
        
        If empDict.Exists(empID) And empDict(empID).Exists(attDate) Then
            ' 找到最新的未配对签到记录
            For j = empDict(empID)(attDate).Count - 1 To 0 Step -1
                If empDict(empID)(attDate)(j)(1) = 0 Then
                    ' 替换为签到签退对：(签到时间, 签退时间, 类型：1=已配对)
                    empDict(empID)(attDate)(j) = Array(empDict(empID)(attDate)(j)(0), outTime, 1)
                    Exit For
                End If
            Next j
        End If
    Next i
    
    ' 统计最大每日签到次数
    maxPunches = 0
    For Each empID In empDict.Keys
        For Each attDate In empDict(empID).Keys
            If empDict(empID)(attDate).Count > maxPunches Then
                maxPunches = empDict(empID)(attDate).Count
            End If
        Next attDate
    Next empID
    
    ' 写入表头
    wsResult.Cells(1, 1).Value = "Employee ID"
    wsResult.Cells(1, 2).Value = "Date"
    For i = 1 To maxPunches
        wsResult.Cells(1, 2 * i + 1).Value = "Check In " & i
        wsResult.Cells(1, 2 * i + 2).Value = "Check Out " & i
        wsResult.Cells(1, 2 * i + 1).NumberFormat = "h:mm:ss"
        wsResult.Cells(1, 2 * i + 2).NumberFormat = "h:mm:ss"
    Next i
    wsResult.Cells(1, 2 * maxPunches + 3).Value = "Total Hours"
    
    ' 填充结果表
    resultRow = 2
    For Each empID In empDict.Keys
        For Each attDate In empDict(empID).Keys
            wsResult.Cells(resultRow, 1).Value = empID
            wsResult.Cells(resultRow, 2).Value = attDate
            totalHours = 0
            
            ' 填充每一组签到签退
            For i = 0 To empDict(empID)(attDate).Count - 1
                punchPair = empDict(empID)(attDate)(i)
                ' 写入签到时间
                If IsDate(punchPair(0)) Then
                    wsResult.Cells(resultRow, 2 * (i + 1) + 1).Value = TimeValue(punchPair(0))
                Else
                    wsResult.Cells(resultRow, 2 * (i + 1) + 1).Value = missingPunch
                End If
                ' 写入签退时间并计算工时
                If UBound(punchPair) >= 1 And IsDate(punchPair(1)) Then
                    wsResult.Cells(resultRow, 2 * (i + 1) + 2).Value = TimeValue(punchPair(1))
                    totalHours = totalHours + (CDbl(punchPair(1)) - CDbl(punchPair(0))) * 24
                Else
                    wsResult.Cells(resultRow, 2 * (i + 1) + 2).Value = missingPunch
                End If
            Next i
            
            ' 填充剩余空列
            For i = empDict(empID)(attDate).Count To maxPunches - 1
                wsResult.Cells(resultRow, 2 * (i + 1) + 1).Value = missingPunch
                wsResult.Cells(resultRow, 2 * (i + 1) + 2).Value = missingPunch
            Next i
            
            ' 写入总工时
            wsResult.Cells(resultRow, 2 * maxPunches + 3).Value = totalHours
            resultRow = resultRow + 1
        Next attDate
    Next empID
    
    ' 自动调整列宽
    wsResult.UsedRange.Columns.AutoFit
    MsgBox "数据合并完成！"
End Sub

修复说明 #

1. 数据结构优化：使用双层字典（员工ID -> 日期）存储每日签到签退记录，确保按日期精准匹配。
2. 匹配逻辑修正：签退数据优先匹配同员工同日期的最新未配对签到记录，避免错位。
3. 结果填充逻辑简化：按实际签到次数逐行填充，避免索引越界问题。
4. 工时计算优化：每组签到签退单独计算时长后求和，符合考勤规则，且缺失数据不影响有效记录的计算。

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