Sub Rabota()
    Dim a(), b()
    Dim i&, n&
    Dim sd As Object, dicLeave As Object
'--------------------
    Set sd = CreateObject("Scripting.Dictionary")
    Set dicLeave = CreateObject("Scripting.Dictionary")
    Set dicArrive = CreateObject("Scripting.Dictionary")
    a = ThisWorkbook.Worksheets("Исходный").UsedRange.Value
    For i = 3 To UBound(a)
        If a(i, 8) = "оф." Or a(i, 9) = "оф." Then
            key_ = a(i, 4) & a(i, 5) & a(i, 6)
            If sd.Exists(key_) Then b = sd(key_) Else b = Array(a(i, 7), a(i, 4), a(i, 6), "'" & a(i, 5), Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, sd.Count + 1)
            If Len(a(i, 8)) Then b(4) = b(4) + 1
            If Len(a(i, 9)) Then b(5) = b(5) + 1
            If Len(a(i, 22)) Then If Left$(a(i, 22), 2) = "вч" Then b(6) = b(6) + 1 Else b(8) = b(8) + 1: dicLeave(a(i, 3)) = b(13)
            If Len(a(i, 23)) Then If Left$(a(i, 23), 2) = "вч" Then b(7) = b(7) + 1 Else b(12) = a(i, 23): b(10) = b(10) + 1
            sd(key_) = b
        End If
    Next
    
    a = sd.items
    For i = 0 To UBound(a)
        If Len(a(i)(12)) Then If dicLeave.Exists(a(i)(12)) Then n = dicLeave(a(i)(12)): a(i)(11) = n: n = n - 1: a(n)(9) = IIf(Len(a(n)(9)), a(n)(9) & ";", "") & i + 1
    Next
    
    With ThisWorkbook.Worksheets("РКОФ")
        With .Cells(7, 1)
            .Value = 1
            With .Resize(sd.Count)
                .DataSeries
                .Offset(, 2).Resize(, 12).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(a))
            End With
        End With
        .Activate
    End With
    Beep
End Sub