Hallo Zusammen,

In zelle 13,3 steht eine Stundenzahl für die tägliche Arbeitszeit. In Spalte A ab zeile 19 im Blatt Main stehen Namen. Ab Spalte 8 Zeile 18 stehen daten für einen Monat. Für jeden Tag und jede Person können Startuhrzeiten wie z.B. 07:00 eingetragen sein. Dann beträgt die Enduhrzeit 07:00 Uhr + Wert aus 13,3, was eine Arbeitszeit von Wert aus 13,3 ergibt. Es kann aber auch ein Zeitraum angegeben sein z.B. 10:00-12:00, was einer Arbeitszeit von 2h ergibt. Es soll nun überprüft werden, ob für eine Person aus Spalte A für gleiche Daten aus Zeile 18 die tägliche Arbeitszeit aus Zelle 13,3 überschritten wurde, wenn also an einem Datum mehrere Zeiten oder Zeiträume und damit die Summe der einzelnen Zeitdifferenzen die tägliche Arbeitszeit überschreitet.

Mein Ansatz:

Sub CheckAndMarkOvertime()
    Dim ws As Worksheet
    Dim nameRange As Range
    Dim dailyHours As Double
    Dim totalWorkHours As Double
    Dim startTime As Date, endTime As Date
    Dim timeDifference As Double
    Dim timeParts() As String
    Dim personName As String
    Dim lastRow As Long, lastCol As Long
    Dim firstRow As Long, firstCol As Long
    Dim cellToCheck As Range
    Dim dateCol As Long
    Dim personRow As Long
    Dim dateRange As Range
    Dim currentDateCell As Range
    Dim personDict As Object
    Dim currentCell As Range
    Dim hoursSum As Double
    Dim i As Long

    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Main")

    ' Daily working hours
    dailyHours = ws.Cells(13, 3).value

    ' Determine the last row and column with data
    With ws.UsedRange
        lastRow = .Rows(.Rows.count).Row
        lastCol = .Columns(.Columns.count).Column
    End With

    ' Determine the first row and column for the data range
    firstRow = 19
    firstCol = 8

    ' Set the range to be colored white
    ws.Range(ws.Cells(firstRow, firstCol), ws.Cells(lastRow, lastCol)).Interior.Color = RGB(255, 255, 255)
    
    ' Define the range for names
    Set nameRange = ws.Range("A" & firstRow & ":A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row)
    
    ' Iterate through each date column
    For dateCol = 1 To (lastCol - firstCol + 1)
        ' Define the range for the current date column
        Set dateRange = ws.Range(ws.Cells(firstRow, firstCol + dateCol - 1), ws.Cells(lastRow, firstCol + dateCol - 1))

        ' Iterate through each row in the name column
        For personRow = firstRow To ws.Cells(ws.Rows.count, 1).End(xlUp).Row
            personName = ws.Cells(personRow, 1).value
            totalWorkHours = 0

            ' Create a dictionary to track the total work hours for this person on this date
            Set personDict = CreateObject("Scripting.Dictionary")
            
            ' Iterate through each cell in the date column for the current person
            For Each cellToCheck In dateRange
                If cellToCheck.Row = personRow Then
                    If cellToCheck.value <> "" Then
                        If InStr(cellToCheck.value, "-") > 0 Then
                            ' Time range
                            timeParts = Split(cellToCheck.value, "-")
                            startTime = CDate(timeParts(0))
                            endTime = CDate(timeParts(1))
                            timeDifference = (endTime - startTime) * 24 ' Convert to hours
                        Else
                            ' Single start time
                            startTime = CDate(cellToCheck.value)
                            endTime = DateAdd("h", dailyHours, startTime)
                            timeDifference = (endTime - startTime) * 24 ' Convert to hours
                        End If
                        
                        totalWorkHours = totalWorkHours + timeDifference
                    End If
                End If
            Next cellToCheck
            
            ' Add total work hours to the dictionary
            personDict(personName) = totalWorkHours
        Next personRow
        
        ' After processing all persons for this date, mark the cells for the date if any person exceeded the daily hours
        For Each currentCell In dateRange
            personName = ws.Cells(currentCell.Row, 1).value
            If personDict.exists(personName) Then
                If personDict(personName) > dailyHours Then
                    ws.Cells(currentCell.Row, firstCol + dateCol - 1).Interior.Color = RGB(255, 255, 0)
                End If
            End If
        Next currentCell
    Next dateCol
End Sub

Leider weiß ich nicht wie ich ein Bild einfügen kann, um das Problem verständlich zu beschreiben. Der Code läuft ohne Probleme durch, er findet allerdings nicht die richtigen Daten und markiert die Zellen für die jeweiligen personen, für die die tägliche Arbeitszeit überschritten wurde.

Vielen Dank