Option Explicit Sub prcEmplJobTimeCount(strSName As String) Dim objSName As Range, intI As Integer, lngFRow As Long, lngLRow As Long Dim aintWeeks() As Integer, asngHours() As Single, IntJ As Integer Dim sngSumOfWeekHours As Single, intWeekN As Integer Dim intMinutes As Integer, intHours As Integer On Error GoTo ExitProc With ThisWorkbook.Worksheets("Лист1") ' Предполагается, что все записи на листе отсортированы по фамилиям, ' а также, что искомая фамилия в таблице обязательно присутствует ' (иначе - ошибка и выход из программы): lngFRow = .Columns(4).Find(strSName, LookIn:=xlValues).Row IntI = lngFRow Do While .Cells(IntI, 4) = strSName IntI = IntI + 1 Loop lngLRow = IntI - 1 Set objSName = Union(Range(.Cells(lngFRow, 2), .Cells(lngLRow, 2)), _ Range(.Cells(lngFRow, 8), .Cells(lngLRow, 8))) End With 'objSName.Select 'Эта строка нужна только на момент отладки (выделяем все записи по сотруднику) With objSName For IntI = 1 To lngLRow - lngFRow If .Cells(IntI, 7) = "Вход" And .Cells(IntI + 1, 7) = "Выход" _ And Day(.Cells(IntI, 1)) = Day(.Cells(IntI + 1, 1)) Then intWeekN = DatePart("ww", .Cells(IntI, 1), vbMonday) ReDim Preserve aintWeeks(IntJ): aintWeeks(IntJ) = intWeekN ReDim Preserve asngHours(IntJ) asngHours(IntJ) = DateDiff("s", .Cells(IntI, 1), .Cells(IntI + 1, 1)) / 3600 IntI = IntI + 1 IntJ = IntJ + 1 End If Next IntI End With Set objSName = Nothing sngSumOfWeekHours = asngHours(0) intWeekN = aintWeeks(0) For IntI = 1 To IntJ - 1 If intWeekN = aintWeeks(IntI) Then sngSumOfWeekHours = sngSumOfWeekHours + asngHours(IntI) Else intHours = Val(sngSumOfWeekHours) intMinutes = (sngSumOfWeekHours - intHours) * 60 'Вывод, к примеру, в окно отладки: Debug.Print strSName & ", неделя "; Format$(aintWeeks(IntI - 1), "0#: ") _ & Format$(intHours, "0# ч") & ". " & Format$(intMinutes, "0# мин") & "." intWeekN = aintWeeks(IntI) sngSumOfWeekHours = asngHours(IntI) End If Next IntI intHours = Val(sngSumOfWeekHours) intMinutes = (sngSumOfWeekHours - intHours) * 60 'Вывод в окно отладки последней записи (если в таблице данных больше чем за 1 неделю): Debug.Print strSName & ", неделя "; Format$(aintWeeks(IntI - 1), "0#: ") _ & Format$(intHours, "0# ч") & ". " & Format$(intMinutes, "0# мин") & "." ExitProc: 'Обработку ошибок не делаю If Err.Number <> 0 Then MsgBox "Ошибка:" & Err.Description End Sub Sub Test() prcEmplJobTimeCount "Петрова" End Sub |