Sub svovach ()
a = [a1].CurrentRegion.Value
ReDim b(1 To UBound(a) / 2, 1 To 2)
Set Dict = CreateObject("scripting.dictionary")
Dim ts, tf, tmp, te, i
For i = 2 To UBound(a)
If Not Dict.exists(Format(a(i, 1), "dd.mm.yyyy")) Then
Dict.Add Format(a(i, 1), "dd.mm.yyyy"), i
ts = Format(a(i, 1), "hh:nn:ss")
Select Case ts
Case Is < #8:00:00 AM#
ts = #8:00:00 AM#
Case #1:00:00 PM# To #2:00:00 PM#
ts = #2:00:00 PM#
Case Is > #5:00:00 PM#
ts = #5:00:00 PM#
End Select
tf = 0
x = x + 1
tmp = a(i, 2)
b(x, 1) = Format(a(i, 1), "dd.mm.yyyy")
End If 'Else
If tmp <> a(i, 2) Then
If a(i, 2) = "âõîä" Then
ts = Format(a(i, 1), "hh:nn:ss")
Select Case ts
Case Is < #8:00:00 AM#
ts = #8:00:00 AM#
Case #1:00:00 PM# To #2:00:00 PM#
ts = #2:00:00 PM#
Case Is > #5:00:00 PM#
ts = #5:00:00 PM#
End Select
Else
tf = Format(a(i, 1), "hh:nn:ss")
Select Case tf

Case Is < #8:00:00 AM#
tf = #8:00:00 AM#
Case #1:00:00 PM# To #2:00:00 PM#
tf = #2:00:00 PM#
Case Is > #5:00:00 PM#
tf = #5:00:00 PM#
End Select
te = CDate(tf) - CDate(ts)
If (CDate(ts) <= #1:00:00 PM#) And (CDate(tf) >= #2:00:00 PM#) Then te = te - (1 / 24)
b(x, 2) = b(x, 2) + te
' Debug.Print Format(te, "hh:nn:ss") & "[-]" & Format(ts, "hh:nn:ss") & "[-]" & Format(tf, "hh:nn:ss")
End If
End If
tmp = a(i, 2)
'End If
Next
[h1].Resize(x, 2) = b
End Sub