Учитывает выходные, праздники, переносы выходных
Писал на основании найденного в интернете. часы и переносы выходных приспособил для своих целей. Списки праздников и проч. можно передать через параметры, но мне для SQL надо именно так.
Посмотрите-может подойдет, а вот насчет обеденных перерывов не хочется заморачиваться.
' SDate,EDate - начачо и конец работы в формате дата-время
' D_H - =0 - вычисление читых раб. дней с учетом праздников
' и переносов выходных;
' =1 - вычисление читых раб. часов при рабочем дней с 9-00 до 18-00
Function NetWorkDayHours(SDate As Date, EDate As Date, D_H As Integer) As Double
Dim HolidaysList()
Dim RList()
Dim ArrMember
Dim RMember
Dim PRAZDNIK, Sperenos, Sprazdnik, Svyhodnoy, Sbudni As Boolean
Dim Eperenos, Eprazdnik, Evyhodnoy, Ebudni As Boolean
Dim SDLT, EDLT, DaysCount As Integer
Dim Stime, Etime, STimeDLT, ETimeDLT As Single
Stime = SDate - Int(SDate)
SDate = DateValue(SDate)
Etime = EDate - Int(EDate)
EDate = DateValue(EDate)
' праздники (Можно как параметр типа RANGE)
HolidaysList = Array( _
"03.01.2012", "04.01.2012", "05.01.2012", "06.01.2012", "07.01.2012", "08.01.2012", "09.01.2012", _
"23.02.2012", "08.03.2012", "09.03.2012", "10.03.2012", "30.04.2012", "01.05.2012", "07.05.2012", _
"08.05.2012", "09.05.2012", "11.06.2012", "12.06.2012", "05.11.2012", "31.12.2012")
' перенос выходных (Можно как параметр типа RANGE)
RList = Array("11.03.2012", "28.04.2012", "05.05.2012", "12.05.2012", "09.06.2012", "29.12.2012")
PRAZDNIK = False
Sperenos = False: Eperenos = False
Sprazdnik = False: Eprazdnik = False
Svyhodnoy = False: Evyhodnoy = False
Sbudni = False: Ebudni = False
For i = SDate To EDate
If Weekday(i, vbMonday) < 6 Then
' исключение праздников
For Each ArrMember In HolidaysList
Z = Format(ArrMember, "dd.mm.yyyy"): x = Format(i, "dd.mm.yyyy")
If Format(ArrMember, "dd.mm.yyyy") = Format(i, "dd.mm.yyyy") Then
PRAZDNIK = True
'Анализ праздников SDate и EDate ----
If i = SDate Then Sprazdnik = True
If i = EDate Then Eprazdnik = True
'----------------------------------
Exit For
Else
PRAZDNIK = False
End If
Next ArrMember
'счетчик рабочих дней -------
If PRAZDNIK = False Then
'Анализ праздников SDate и EDate ----
If i = SDate Then Sbudni = True
If i = EDate Then Ebudni = True
'----------------------------------
DaysCount = DaysCount + 1 'СЧИТАЕМ ДНИ +++++++++++++++++++++++++++++++++++
End If
Else
'Анализ выходных SDate и EDate ----
If i = SDate Then Svyhodnoy = True
If i = EDate Then Evyhodnoy = True
'----------------------------------
'Перенос выходных =
If Weekday(i, vbMonday) = 6 Or Weekday(i, vbMonday) = 7 Then
For Each RMember In RList
If Format(RMember, "dd.mm.yyyy") = Format(i, "dd.mm.yyyy") Then
DaysCount = DaysCount + 1
'Анализ переноса SDate и EDate ----
If i = SDate Then Sperenos = True
If i = EDate Then Eperenos = True
'----------------------------------
Exit For
End If
Next RMember
End If
End If
Next i
If D_H = 0 Then ' ВЫВОД ТОЛЬКО ЧИСТЫХ РАБ.ДНЕЙ
NetWorkDayHours = DaysCount
Exit Function
End If
'РАСЧЕТ РАБОЧИХ ЧАСОВ при рабочем дне с 9-00 до 18-00======================================
'СДВИГ НАЧАЛА РАБОТЫ---------------------------------
If Sprazdnik Or Svyhodnoy Then
STimeDLT = 0: SDLT = 0
ElseIf (Svyhodnoy And Sperenos) Or Sbudni Then
If Stime > 0.75 Then ' 18-00
STimeDLT = 0: SDLT = -1
ElseIf Stime < 0.375 Then ' 9-00
STimeDLT = 0: SDLT = 0
Else
STimeDLT = (0.75 - Stime) * 24: SDLT = -1
End If
End If
'СДВИГ КОНЦА РАБОТЫ---------------------------------
If Eprazdnik Or Evyhodnoy Then
ETimeDLT = 0: EDLT = 0
ElseIf (Evyhodnoy And Eperenos) Or Ebudni Then
If Etime > 0.75 Then
ETimeDLT = 0: EDLT = 0
ElseIf Etime < 0.375 Then
ETimeDLT = 0: EDLT = -1
Else
ETimeDLT = (Etime - 0.375) * 24: EDLT = -1
End If
End If
' ВЫВОД ЧИСТЫХ РАБ. ЧАСОВ
NetWorkDayHours = (DaysCount + SDLT + EDLT) * 9 + STimeDLT + ETimeDLT
End Function
