Option Explicit
'====================================================================================================
Dim fReport As Boolean
Const tmW1# = #9:00:00 AM#
Const tmW2# = #6:00:00 PM#
'====================================================================================================
' Подсчёт рабочих часов между двумя датами (дата-время)
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=137621&TITLE_SEO=137621-WorkHoursFull-rabchasy-funktsiya-dlya-polucheniya-raznitsy-mezhdu-dvumya-d&MID=1117381&result=edit#message1117381
'====================================================================================================
' Версия по аналогии с PLEX (https://www.planetaexcel.ru/plex/version20171.php)
'
' (DateBegin) = дата-время НАЧАЛА отсчёта. Если просто дата, то время берём по переменной или константе
' (DateEnd) = дата-время КОНЦА отсчёта. Если просто дата, то время берём по переменной или константе
' [WorkBeg] = время НАЧАЛА работы (общее). Должно быть меньше суток (1 - в десятичном представлении Excel). 9:00 - по умолчанию
' [WorkEnd] = время ОКОНЧАНИЯ работы (общее). Должно быть меньше суток (1 - в десятичном представлении Excel). 18:00 - по умолчанию
' [rngOut] = диапазон НЕрабочих дат
' [rngAdd] = диапазон РАБОЧИХ дат
'====================================================================================================
Sub SimpleTester()
With shSimple
MsgBox WorkHours(.Range("a17"), .Range("b17"), .Range("b2"), .Range("b3"), .Range("a6:a13"), .Range("b6"))
End With
End Sub
'====================================================================================================
Function WorkHours(DateBeg#, DateEnd#, Optional WorkBeg#, Optional WorkEnd#, Optional rngOut As Range, Optional rngAdd As Range)
Dim dOut As New Dictionary, dWork As New Dictionary
Dim fOut As Boolean, fAdd As Boolean
Dim arr, x, flag As Boolean
Dim s#, sClear#, t1#, t2#, d&, b&, e&
On Error GoTo ex ' в любой непонятной ситуации (по ошибке) выходим
WorkHours = "!!! Parameters !!!"
x = Check(DateBeg, DateEnd, WorkBeg, WorkEnd) ' проверка переданных аргументов функции
If x <> True Then WorkHours = x: GoTo ex
' ПРОВЕРЯЕМ МАССИВ ИСКЛЮЧАЕМЫХ =======================================
WorkHours = "!!! RangeOut !!!"
If Not rngOut Is Nothing Then ' собираем ПРОПУСКАЕМЫЕ даты в словарь
arr = rngOut.Value2
If Not IsArray(arr) Then arr = Array(arr)
For Each x In arr
If Len(x) = 0 Then GoTo nx1
If Not IsNumeric(x) Then GoTo ex
x = --x: If x <> Abs(Fix(x)) Or x = 0 Then GoTo ex
If dOut.Exists(x) Then GoTo ex
dOut.Add x, 0
nx1: Next x
End If
If dOut.Count Then fOut = True
' ПРОВЕРЯЕМ МАССИВ ВКЛЮЧАЕМЫХ ========================================
WorkHours = "!!! RangeAdd !!!"
If Not rngAdd Is Nothing Then ' собираем ВКЛЮЧАЕМЫЕ даты в словарь
arr = rngAdd.Value2
If Not IsArray(arr) Then arr = Array(arr)
For Each x In arr
If Len(x) = 0 Then GoTo nx2
If Not IsNumeric(x) Then GoTo ex
x = --x: If x <> Abs(Fix(x)) Or x = 0 Then GoTo ex
If dOut.Exists(x) Then GoTo ex ' если было в ИСКЛЮЧАЕМЫХ, то ошибка
If dWork.Exists(x) Then GoTo ex ' если уже было в ДОБАВЛЯЕМЫХ, то ошибка
dWork.Add x, 0
nx2: Next x
End If
If dWork.Count Then fAdd = True
' СЧИТАЕМ РАБОЧИЕ ЧАСЫ =================================================================================
WorkHours = "!!! COUNT !!!"
b = Fix(DateBeg): e = Fix(DateEnd)
For d = b To e ' цикл с начала отсчёта по конец
flag = False ' обнуляемся
t1 = WorkBeg: t2 = WorkEnd ' берём время по умолчанию
If fAdd Then
If dWork.Exists(d) Then flag = True ' если ЕСТЬ в словаре ВКЛЮЧАЕМЫХ, то ставим флаг ВКЛЮЧАЕМЫХ
End If
If Not flag Then
If Weekday(d, vbMonday) > 5 Then GoTo nx3 ' если очередная дата это суббота или воскресенье, то пропускаем
If fOut Then
If dOut.Exists(d) Then GoTo nx3 ' если дата есть в списке ИСКЛЮЧАЕМЫХ, то пропускаем её
End If
End If
If d = b Then
s = DateBeg - b: If s <> 0 Then t1 = s ' если текущая дата — это НАЧАЛО отсчёта и у этой даты указано время, то принимаем его в качестве НАЧАЛА работы для этого дня (приоритет)
End If
If d = e Then
s = DateEnd - e: If s <> 0 Then t2 = s ' если текущая дата — это КОНЕЦ отсчёта и у этой даты указано время, то принимаем его в качестве ОКОНЧАНИЯ работы для этого дня (приоритет)
End If
s = t2 - t1: If s < 0 Then s = 0 ' считаем количество отработанных часов в данный рабочий день. Если начало позже окончания, то принимаем за 0
sClear = sClear + s ' считаем "чистое" время
' Debug.Print CDate(d), Round(24 * t1), Round(24 * t2), Round(24 * s), Round(24 * sClear)
nx3: Next d
fin: WorkHours = Round(24 * sClear, 6)
ex: If fReport Then fReport = False
End Function
'====================================================================================================
' Версия с множественными параметрами
'
' (DateBegin) = дата-время НАЧАЛА отсчёта. Если просто дата, то время берём по переменной или константе
' (DateEnd) = дата-время КОНЦА отсчёта. Если просто дата, то время берём по переменной или константе
' [TimeTable] = график работы в формате "#######" только из нолей и единиц ("1111100" - это стандартная пятидневка, значение "по-умолчанию") — одинаковый для КАЖДОЙ НЕДЕЛИ или "N/N DD/MM/YYYY". Пример: "5/2 11/01/2021", читается как "пять через два с 11 января 2021 года"
' [WorkBeg] = время НАЧАЛА работы (общее). Должно быть меньше суток (1 - в десятичном представлении Excel). 9:00 - по умолчанию
' [WorkEnd] = время ОКОНЧАНИЯ работы (общее). Должно быть меньше суток (1 - в десятичном представлении Excel). 18:00 - по умолчанию
' Расшифровка для значений -1; 4 и ">" - соответственно: из расчёта отработанного времени в день ОТНИМАТЬ ОДИН час, если отработано БОЛЕЕ ЧЕТЫРЁХ часов. Подразумевается обед
' [AddHours] = добавить (можно отнять, добавив отрицательное число) указанное количество часов при выполнении условий [DayWork] и [Crit]. 0 — по умолчанию
' [DayHours] = сколько часов в каждый день нужно отработать, чтобы выполнить условие. 0 — по умолчанию
' [Crit] = критерий сравнения количества отработанных часов в каждый день с [DayWork]. Допускается 6 классических вариантов сравнения: "<", "<=", "=", "<>", ">=", "=" — по умолчанию
' [rngOut] = диапазон НЕрабочих дат. Пустые будут пропущены
' [rngAdd] = диапазон РАБОЧИХ дат. Допускается до 3ёх столбцов в строгом порядке "Рабочие даты" - "Начало работы" - "Конец работы". Если в 1ом столбце есть данные, то проверяем остальные столбцы. Если в них нет данных, то берём по общему
'====================================================================================================
Sub Report()
Dim d1#, d2#, t1#, t2#
fReport = True
d1 = #1/1/2021 12:00:00 PM#
d2 = #3/1/2021 9:00:00 AM#
t1 = #8:00:00 AM#
t2 = #5:00:00 PM#
With shHard
WorkHoursFull d1, d2, t1, t2, , , , , .Range("A6:A13"), .Range("B6:D13")
End With
End Sub
'====================================================================================================
Function WorkHoursFull(DateBeg#, DateEnd#, Optional WorkBeg#, Optional WorkEnd#, Optional TimeTable$, Optional AddHours#, Optional DayHours#, Optional Crit$, Optional rngOut As Range, Optional rngAdd As Range)
Dim dDaysW As New Dictionary, dOut As New Dictionary, dWork As New Dictionary
Dim fReg As Boolean, fOut As Boolean, fAdd As Boolean
Dim fCompare As Boolean, fCL As Boolean, fCLE As Boolean, fCE As Boolean, fCNE As Boolean, fCBE As Boolean, fCB As Boolean
Dim arr, x, tmp, arrOne(1 To 1, 1 To 1), flag As Boolean, fDO As Boolean, fDW As Boolean
Dim tx$, s#, ss#, sClear#, sAdd#, AH#, t1#, t2#, r&, c&, n&, d&, w&, o&
On Error GoTo ex ' в любой непонятной ситуации (по ошибке) выходим
WorkHoursFull = "!!! Parameters !!!"
x = Check(DateBeg, DateEnd, WorkBeg, WorkEnd) ' проверка переданных аргументов функции
If x <> True Then WorkHoursFull = x: GoTo ex
If AddHours <> 0 Then
If DayHours < 0 Then GoTo ex
fCompare = True
DayHours = DayHours / 24 ' переводим часы в часть от дня (нормализованное время)
AH = AddHours: AddHours = AddHours / 24
If Crit = "" Then fCE = True: GoTo nx0
If Crit = "<" Then fCL = True: GoTo nx0
If Crit = "<=" Then fCLE = True: GoTo nx0
If Crit = "=" Then fCE = True: GoTo nx0
If Crit = "<>" Then fCNE = True: GoTo nx0
If Crit = ">=" Then fCBE = True: GoTo nx0
If Crit = ">" Then fCB = True: GoTo nx0
GoTo ex
End If
nx0:
' ПРОВЕРЯЕМ МАССИВ ИСКЛЮЧАЕМЫХ =======================================
WorkHoursFull = "!!! RangeOut !!!"
If Not rngOut Is Nothing Then ' собираем ПРОПУСКАЕМЫЕ даты в словарь
arr = rngOut.Value2
If Not IsArray(arr) Then arrOne(1, 1) = arr: arr = arrOne
For Each x In arr
If Len(x) = 0 Then GoTo nx1
If Not IsNumeric(x) Then GoTo ex
x = --x: If x <> Abs(Fix(x)) Or x = 0 Then GoTo ex
If dOut.Exists(x) Then GoTo ex
dOut.Add x, 0
nx1: Next x
End If
If dOut.Count Then fOut = True
' ПРОВЕРЯЕМ МАССИВ ВКЛЮЧАЕМЫХ ========================================
WorkHoursFull = "!!! RangeAdd !!!"
If Not rngAdd Is Nothing Then ' собираем ВКЛЮЧАЕМЫЕ даты (и время учёта, если есть) в словарь
c = rngAdd.Columns.Count
If c > 3 Then GoTo ex
If c > 1 Then flag = True
arr = rngAdd.Value2
If Not IsArray(arr) Then arrOne(1, 1) = arr: arr = arrOne
For r = 1 To UBound(arr, 1)
If Len(arr(r, 1)) = 0 Then GoTo nx2
If Not IsNumeric(arr(r, 1)) Then GoTo ex
arr(r, 1) = --arr(r, 1): tmp = 0
If arr(r, 1) <> Abs(Fix(arr(r, 1))) Or arr(r, 1) = 0 Then GoTo ex
If dOut.Exists(arr(r, 1)) Then GoTo ex ' если было в ИСКЛЮЧАЕМЫХ, то ошибка
If dWork.Exists(arr(r, 1)) Then GoTo ex ' если уже было в ДОБАВЛЯЕМЫХ, то ошибка
If flag Then ' если больше одного столбца …
ReDim tmp(1)
For c = 2 To UBound(arr, 2)
If Len(arr(r, c)) Then tmp(c - 2) = --arr(r, c)
Next c
x = Check(tmp)
If x <> True Then WorkHoursFull = "!!! RangeAdd !!!": GoTo ex
End If
dWork.Add arr(r, 1), tmp
nx2: Next r
End If
If dWork.Count Then fAdd = True
' ГОТОВИМ ГРАФИК =============================
WorkHoursFull = "!!! TimeTable !!!"
If TimeTable = "" Then TimeTable = "1111100"
If TimeTable Like "#######" Then ' если график регулярный …
fReg = True ' … ставим флаг регулярного графика
For r = 1 To Len(TimeTable) ' … цикл по всем символам строки-графика
tx = Mid(TimeTable, r, 1)
If tx = "1" Then
dDaysW.Add r, 0 ' добавляем порядковый номер дня недели в словарь рабочих
Else
If tx <> "0" Then GoTo ex ' если очередной символ это не "0", и не "1", то выходим с ошибкой
End If
Next r
ElseIf TimeTable Like "#/# ##/##/####" Then ' если график НЕрегулярный …
d = CDate(Mid(TimeTable, 5)) ' дата из строки-графика
n = Fix(DateBeg) - d ' разница в целых днях между началом отсчёта разницы времени и началом отсчёта НЕрегулярного графика
If n < 0 Then GoTo ex ' начало отсчёта НЕрегулярного графика не может быть ПОЗЖЕ даты начала отсчёта разницы времени
w = --Left(TimeTable, 1) ' дни работы из строки-графика
o = --Mid(TimeTable, 3, 1) ' дни отдыха из строки-графика
If w < 1 Or o < 1 Then GoTo ex ' дни не могут быть отрицательными
r = w + o ' складываем дни работы и отдыха
c = n \ r ' сколько целых блоков можно пропустить до начала отсчёта разницы времени. Целочисленное деление
r = d + r * c ' ближайшая дата к началу отсчёта разницы времени, в которой НЕрегулярный график начинается сначала
r = r - 1
c = Fix(DateEnd) ' дата окончания расчёта
Do
For d = 1 To w
r = r + 1
dDaysW.Add r, 0 ' добавляем очередную ДАТУ работы в словарь
Next d
r = r + o ' пропускаем отдых
If r > c Then Exit Do
Loop
Else
GoTo ex ' если маска строки-графика не распознана, то выходим
End If
' СЧИТАЕМ РАБОЧИЕ ЧАСЫ =================================================================================
WorkHoursFull = "!!! COUNT !!!"
d = Fix(DateBeg): o = Fix(DateEnd)
If fReport Then ReDim arr(1 To o - d + 1, 1 To 10): n = 0
For r = d To o ' цикл с начала отсчёта по конец
s = 0: fDO = False: fDW = False ' обнуляем сумму и снимаем флаги
If fAdd Then
If dWork.Exists(r) Then ' если ЕСТЬ в словаре ВКЛЮЧАЕМЫХ, то берём время работы оттуда
fDW = True ' ставим флаги УЧЁТА и ВКЛЮЧАЕМЫХ
x = dWork(r): t1 = x(0): t2 = x(1)
End If
End If
If Not fDW Then
If fReg Then
w = Weekday(r, vbMonday) ' для регулярного графика: день недели
Else
w = r ' для "плавающего" графика: очередная дата из цикла
End If
If Not dDaysW.Exists(w) Then GoTo nx3 ' если очередной даты (или дня недели) НЕТ в списке рабочих по графику, то пропускаем
If fOut Then
If dOut.Exists(r) Then
fDO = True: GoTo nx3 ' если дата есть в списке ИСКЛЮЧАЕМЫХ, то пропускаем её
End If
End If
t1 = WorkBeg: t2 = WorkEnd ' берём время по умолчанию
End If
If r = d Then
s = DateBeg - d: If s <> 0 Then t1 = s ' если текущая дата — это НАЧАЛО отсчёта и у этой даты указано время, то принимаем его в качестве НАЧАЛА работы для этого дня (приоритет)
End If
If r = o Then
s = DateEnd - o: If s <> 0 Then t2 = s ' если текущая дата — это КОНЕЦ отсчёта и у этой даты указано время, то принимаем его в качестве ОКОНЧАНИЯ работы для этого дня (приоритет)
End If
s = t2 - t1: If s < 0 Then s = 0 ' считаем количество отработанных часов в данный рабочий день. Если начало позже окончания, то принимаем за 0
sClear = sClear + s ' считаем "чистое" время
If fCompare Then
flag = False
If fCL Then
If s < DayHours Then flag = True
ElseIf fCLE Then
If s <= DayHours Then flag = True
ElseIf fCE Then
If s = DayHours Then flag = True
ElseIf fCNE Then
If s <> DayHours Then flag = True
ElseIf fCBE Then
If s >= DayHours Then flag = True
ElseIf fCB Then
If s > DayHours Then flag = True
End If
If flag Then sAdd = sAdd + AddHours
End If
nx3: If fReport Then
n = n + 1 ' строка отчёта
arr(n, 1) = n ' номер п/п
arr(n, 2) = CDate(r) ' дата
arr(n, 3) = Weekday(r, vbMonday) ' день недели
If fDO Then
tx = "вых"
ElseIf fDW Then
tx = "раб"
Else
tx = "—"
End If
arr(n, 4) = tx ' наличие в списках
arr(n, 5) = (s <> 0) ' день учтён?
arr(n, 6) = 24 * t1 ' время "с …" В ЧАСАХ
arr(n, 7) = 24 * t2 ' время "по …" В ЧАСАХ
arr(n, 8) = 24 * s ' разница времени (принятая) В ЧАСАХ
If flag Then s = AH Else s = 0
arr(n, 9) = s ' корректировка времени В ЧАСАХ
arr(n, 10) = arr(n, 8) + s ' всего учтено рабочего времени в данную дату В ЧАСАХ
ss = ss + arr(n, 10) ' сбор суммы ЧАСОВ
End If
Next r
fin: s = Round(24 * (sClear + sAdd), 6)
WorkHoursFull = s
On Error GoTo 0
If Not fReport Then Exit Function Else fReport = False
' выводим отчёт на лист
Application.ScreenUpdating = False
r = Application.Calculation: Application.Calculation = xlCalculationManual
Worksheets.Add after:=ActiveSheet
ActiveWindow.DisplayGridlines = False
With Cells
.Font.Name = "Times New Roman"
.Font.Size = 9
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.ShrinkToFit = False
End With
With Rows(1)
.HorizontalAlignment = xlCenter
.Font.Bold = True
.WrapText = True
End With
Cells(1, 1).Resize(1, UBound(arr, 2)).Value2 = Array("№ п/п", "Дата", "День Недели", "Есть в СПИСКАХ?", "День учтён?", "Время «с …»", "Время «по …»", "Чистое время", "Коррекция времени", "ВСЕГО ВРЕМЕНИ")
Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
Set tmp = Cells(1, 1).Resize(UBound(arr, 1) + 1, UBound(arr, 2))
With tmp
ActiveSheet.ListObjects.Add xlSrcRange, tmp, , xlYes, , "PaRADoX_Flat"
.Borders.LineStyle = True
.Columns.ColumnWidth = 10
.AutoFilter
.Columns.AutoFit
End With
ActiveSheet.ListObjects(1).ShowTotals = True
Rows(1).AutoFit
Application.ScreenUpdating = True
Application.Calculation = r
ss = Round(ss, 6)
x = Abs(Round(s - ss, 6))
If x <> 0 Then MsgBox "The difference between the amounts «" & s & "» and «" & ss & "» is «" & x & "» instead of ZERO", vbCritical, "WorkHoursFull": GoTo ex
MsgBox "Report of WorkHours count from " & Format(DateBeg, "DD.MM.YYYY hh:mm:ss") & " to " & Format(DateEnd, "DD.MM.YYYY hh:mm:ss") & " (" & UBound(arr, 1) & " days) is successfully DONE", vbInformation, "WorkHoursFull"
ex: fReport = False
End Function
'====================================================================================================
'====================================================================================================
'====================================================================================================
Private Function Check(tmpDB, Optional DE#, Optional WB#, Optional WE#)
Dim DB#, fArr As Boolean
On Error GoTo ex
Check = "!!! Check !!!"
If IsArray(tmpDB) Then ' если передан массив, то это только проверка времени работы для включаемых дат
fArr = True
If UBound(tmpDB) <> 1 Then GoTo ex
WB = tmpDB(0)
WE = tmpDB(1)
ElseIf IsNumeric(DB) Then
DB = tmpDB
Else
GoTo ex
End If
If Not fArr Then
Check = "!!! DateBegEnd !!!"
If DB < 1 Or DE < 1 Then GoTo ex ' даты должны быть
If DB >= DE Then GoTo ex ' конец отсчёта должен быть больше начала
End If
Check = "!!! TimeWork !!!"
If WB > 1 Or WE > 1 Then GoTo ex ' часы должны быть меньше единицы
If WB < 0 Or WE < 0 Then GoTo ex ' часы не могут быть отрицательными
If WB = 0 Then WB = tmW1 ' если часы НАЧАЛА отсутствуют, то принимаем константу
If WE = 0 Then WE = tmW2 ' если часы ОКОНЧАНИЯ отсутствуют, то принимаем константу
If WB >= WE Then GoTo ex ' часы ОКОНЧАНИЯ должны быть больше НАЧАЛА
If fArr Then
tmpDB = Array(WB, WE)
Else
tmpDB = DB
End If
Check = True
ex: End Function
'==================================================================================================== |