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 |
Как реализовать - не представляю. Для примера приложу пример файла отчета за пару дней. 
