JekG
Silver Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
vlth
Немного разобрался с работой макроса. ВАш вариант не сработал изначально, потому пришлось его слегка подправить. Вышло вот что
Код: Option Explicit
Function 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# мин") & "."
prcEmplJobTimeCount = intHours
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# мин") & "."
prcEmplJobTimeCount = intHours
ExitProc:
'Обработку ошибок не делаю
If Err.Number <> 0 Then MsgBox "Ошибка:" & Err.Description
End Function
Sub Test()
Dim s, n, j, i, b, fam(1000) As String
n = 1
fam(1) = Range("D5")
i = 5
While Range("D" & i) <> ""
b = False
For j = 1 To n
If Range("D" & i) = fam(j) Then
b = True
End If
Next j
If Not b Then
n = n + 1
fam(n) = Range("D" & i)
End If
i = i + 1
Wend
Range("K5:M1663").Select
Selection.ClearContents
For i = 1 To n
s = prcEmplJobTimeCount(fam(i))
Range("K" & (5 + i)) = fam(i) + " проработал(а): "
Range("L" & (5 + i)) = s
Range("M" & (5 + i)) = "часов!"
Next i
End Sub |
Сейчас вроде работает, но корректно считает почему-то не для всех сотрудников. У некотрых рабочая неделя длится по 3 -4 часа, хотя судя по входам и выходам это не так. Можете ли посоветовать где ошибка?
И еще макрос считает только час. Как сделать подсчет минут и секунд. Поскольку человек проработавший 45 минут на работе таки был...
И еще не логичнее ли индентифицировать людей по номеру пропуска (в поле Отчество). Отрабатывать по уникальной цифре вроде проще чем по фамилии.
PS Простите если ляпаю глупости  |
Всего записей: 2695 | Зарегистр. 12-10-2005 | Отправлено: 13:11 17-12-2009 | Исправлено: JekG, 13:15 17-12-2009 |
|
