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
'====================================================================================================