将excel中的两个考勤表与VBA合并，返回错误的输出-解网

问：

我分别在表1和表2中有两个表。

工作表 1 中的表格包含员工签入记录，与工作表 2 相同，只是它用于签出。

我一直在尝试将它们合并到一个表格中，并列出每个员工每天的总工作时间。

我将举例说明我的输入和预期输出与我得到的输出。

希望有人能帮助我解决代码问题。

输入 1（打卡表）：

输入 2（打孔表）：

预期输出：

我从代码中得到的输出：

我的代码：

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

数组 Excel VBA

Sub CombineAttendanceData()
    Dim wsA As Worksheet, wsB As Worksheet, wsResult As Worksheet
    
    Set wsA = ThisWorkbook.Sheets("Sheet1")
    Set wsB = ThisWorkbook.Sheets("Sheet2")
    Set wsResult = CreateOrGetResultSheet()
    
    Dim AttendanceData As Object
    Set AttendanceData = CreateObject("Scripting.Dictionary")
    
    PopulateDictionaryFromSheet wsA, AttendanceData, "_In"
    PopulateDictionaryFromSheet wsB, AttendanceData, "_Out"
    
    PrintDataToResultSheet wsResult, AttendanceData
    FormatResultSheet wsResult
End Sub

Private Function CreateOrGetResultSheet() As Worksheet
    Dim ws As Worksheet
    
    ' Check if "Attendance Result" worksheet already exists. If it does, delete it.
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = "Attendance Result" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next ws

    ' Add a new worksheet for the attendance results
    Set CreateOrGetResultSheet = ThisWorkbook.Sheets.Add
    CreateOrGetResultSheet.Name = "Attendance Result"
    
    ' Set the header for the new columns
    With CreateOrGetResultSheet
        .Cells(1, 1).Value = "Employee ID"
        .Cells(1, 2).Value = "Date"
        .Cells(1, 3).Value = "1st in"
        .Cells(1, 4).Value = "1st out"
        .Cells(1, 5).Value = "2nd in"
        .Cells(1, 6).Value = "2nd out"
        .Cells(1, 7).Value = "Total Hours"
    End With
End Function


Private Sub PopulateDictionaryFromSheet(ByRef ws As Worksheet, ByRef AttendanceData As Object, suffix As String)
    Dim LastRow As Long, EmployeeID As Long, EmployeeDate As Date, EmployeeDateKey As String, CurrentSuffix As String
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For i = 2 To LastRow
        EmployeeID = ws.Range("B" & i).Value
        EmployeeDate = ws.Range("A" & i).Value
        EmployeeDateKey = Format(EmployeeDate, "YYYY-MM-DD")
        
        If IsTimeValue(ws.Range("C" & i)) Then
            ' Determine if this is the first or second entry for this type (In or Out)
            CurrentSuffix = DetermineSuffix(AttendanceData, CStr(EmployeeID) & "_" & EmployeeDateKey, suffix)
            
            If Not AttendanceData.Exists(CStr(EmployeeID) & "_" & EmployeeDateKey & CurrentSuffix) Then
                AttendanceData(CStr(EmployeeID) & "_" & EmployeeDateKey & CurrentSuffix) = ws.Range("C" & i).Value
            End If
        End If
    Next i
End Sub

Private Function DetermineSuffix(ByRef AttendanceData As Object, baseKey As String, originalSuffix As String) As String
    ' Check if the original key (like "_In" or "_Out") exists, if it does then this is a second entry so append "2"
    If AttendanceData.Exists(baseKey & originalSuffix) Then
        DetermineSuffix = originalSuffix & "2"
    Else
        DetermineSuffix = originalSuffix
    End If
End Function

Private Sub PrintDataToResultSheet(ByRef wsResult As Worksheet, ByRef AttendanceData As Object)
    Dim CurrentRowB As Long, key As Variant, parts() As String
    
    ' Populate the result worksheet
    CurrentRowB = 2
    Dim uniqueKeys As Object
    Set uniqueKeys = CreateObject("Scripting.Dictionary")

    For Each key In AttendanceData.Keys
        parts = Split(key, "_")
        If Not uniqueKeys.Exists(parts(0) & "_" & parts(1)) Then
            uniqueKeys(parts(0) & "_" & parts(1)) = CurrentRowB
            wsResult.Cells(CurrentRowB, 1).Value = parts(0)
            wsResult.Cells(CurrentRowB, 2).Value = DateValue(parts(1))
            CurrentRowB = CurrentRowB + 1
        End If
        
        Select Case parts(2)
            Case "In"
                wsResult.Cells(uniqueKeys(parts(0) & "_" & parts(1)), 3).Value = AttendanceData(key)
            Case "Out"
                wsResult.Cells(uniqueKeys(parts(0) & "_" & parts(1)), 4).Value = AttendanceData(key)
            Case "In2"
                wsResult.Cells(uniqueKeys(parts(0) & "_" & parts(1)), 5).Value = AttendanceData(key)
            Case "Out2"
                wsResult.Cells(uniqueKeys(parts(0) & "_" & parts(1)), 6).Value = AttendanceData(key)
        End Select
    Next key

    ' Add formula to calculate total hours. Assumes a 24-hour format.
    For i = 2 To wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Row
        wsResult.Cells(i, 7).Formula = "=IF(ISNUMBER(D" & i & "),D" & i & "-C" & i & ",0) + IF(ISNUMBER(F" & i & ") * ISNUMBER(E" & i & "),F" & i & "-E" & i & ",0)"
    Next i
End Sub

Private Sub FormatResultSheet(ByRef ws As Worksheet)
    ws.Range("C:F").NumberFormat = "h:mm:ss AM/PM"
    ws.Range("G:G").NumberFormat = "[h]:mm:ss" ' Format for total hours to handle times greater than 24 hours if needed
    ' Optional: AutoFit columns for better visibility
    ws.Columns("A:G").AutoFit
End Sub

Private Function IsTimeValue(targetCell As Range) As Boolean
    IsTimeValue = False
    If IsNumeric(targetCell.Value) And Int(targetCell.Value) = 0 And targetCell.Value <> 0 Then
        IsTimeValue = True
    End If
End Function

Option Explicit
Sub Demo()
    Const MISSING_DT = "Missing"
    Dim objDic As Object, rngData As Range
    Dim i As Long, j As Long
    Dim arrData, arrRes(), arrTotal(), sKey
    Dim oSht As Worksheet, srcSheet As Worksheet
    Set objDic = CreateObject("scripting.dictionary")
    Set srcSheet = Sheets("Sheet1") ' Modify as needed
    ' Consolidate two tables
    Set oSht = Sheets.Add
    srcSheet.ListObjects("Table_In").Range.Copy oSht.Cells(1, 1)
    oSht.Range("D1") = "Flag"
    ' Add a colum named "Flag" which is filled w/ In or Out
    oSht.Range(oSht.ListObjects(1).Name & "[Flag]").Value = "In"
    srcSheet.ListObjects("Table_Out").DataBodyRange.Copy oSht.Cells(1, 1).End(xlDown).Offset(1)
    oSht.Range(oSht.ListObjects(1).Name & "[Flag]").SpecialCells(xlCellTypeBlanks).Value = "Out"
    ' Sort table
    oSht.ListObjects(1).Range.Sort key1:="ID Number", Order1:=xlAscending, key2:="Date", _
        Order2:=xlAscending, key3:="Time", Order3:=xlAscending, Header:=xlYes
    arrData = oSht.ListObjects(1).DataBodyRange.Value
    oSht.ListObjects(1).Range.Clear
    Dim pair_cnt As Integer
    ReDim arrRes(UBound(arrData), 1 To 2)
    ReDim arrTotal(UBound(arrData), 0)
    ' Output table header
    arrRes(0, 1) = "Date"
    arrRes(0, 2) = "ID Number"
    arrTotal(0, 0) = "Total/Day"
    j = 0: pair_cnt = 0
    For i = LBound(arrData) To UBound(arrData)
        ' Date + ID as key
        sKey = arrData(i, 1) & "|" & arrData(i, 2)
        If objDic.exists(sKey) Then
            objDic(sKey) = objDic(sKey) + 1
        Else
            ' Collect Date, ID
            j = j + 1
            arrRes(j, 1) = arrData(i, 1)
            arrRes(j, 2) = arrData(i, 2)
            objDic(sKey) = 1
        End If
        If objDic(sKey) > pair_cnt Then
            ' Extend columns
            pair_cnt = objDic(sKey)
            ReDim Preserve arrRes(UBound(arrData), 1 To pair_cnt * 2 + 2)
            ' Column header
            arrRes(0, pair_cnt * 2 + 1) = "In_" & pair_cnt
            arrRes(0, pair_cnt * 2 + 2) = "Out_" & pair_cnt
        End If
        ' Loading punch data
        If arrData(i, 4) = "In" Then
            arrRes(j, objDic(sKey) * 2 + 1) = arrData(i, 3)
            If arrData(i + 1, 4) = "Out" Then
                arrRes(j, objDic(sKey) * 2 + 2) = arrData(i + 1, 3)
                arrTotal(j, 0) = arrTotal(j, 0) + arrData(i + 1, 3) - arrData(i, 3)
                i = i + 1
            Else
                arrRes(j, objDic(sKey) * 2 + 2) = MISSING_DT
            End If
        Else
            arrRes(j, objDic(sKey) * 2 + 1) = MISSING_DT
            arrRes(j, objDic(sKey) * 2 + 2) = arrData(i, 3)
        End If
    Next i
    ' Write data to work sheet
    With oSht.Range("A3")
        .Resize(UBound(arrRes), UBound(arrRes, 2)).Value = arrRes
        .Offset(0, 2).Resize(, pair_cnt * 2 + 1).EntireColumn.NumberFormat = "h:mm:ss"
        .End(xlToRight).Offset(0, 1).Resize(UBound(arrRes), 1) = arrTotal
    End With
End Sub

上一个：如何动态计算动态数组中两个值之间的差异？

下一个：将数组写入已筛选的范围

将excel中的两个考勤表与VBA合并，返回错误的输出

combining two attendance tables in excel with VBA returning wrong output

评论

评论