---

Option Explicit

Private Const FIRST_DATA_ROW As Long = 5

Private Const ID_COLUMN As Long = 1          ' A
Private Const STATUS_COLUMN As Long = 9      ' I

Private Const US_DAYS_COLUMN As Long = 14    ' N
Private Const OKB_DAYS_COLUMN As Long = 15   ' O

Private Const HEADER_ROW As Long = 4

Private Const HISTORY_SHEET_NAME As String = "ИсторияСтатусов"


Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wsHistory As Worksheet

    Dim oldValue As String
    Dim newValue As String

    Dim objectID As Variant
    Dim historyRow As Long

    ' Обрабатываем только изменение одной ячейки
    If Target.CountLarge <> 1 Then Exit Sub

    ' Только столбец I
    If Target.Column <> STATUS_COLUMN Then Exit Sub

    ' Только начиная с I5
    If Target.Row < FIRST_DATA_ROW Then Exit Sub

    On Error GoTo ErrorHandler

    ' Сначала сохраняем новое значение.
    ' До Application.Undo нельзя изменять книгу.
    newValue = Trim$(CStr(Target.Value))

    ' Получаем старое значение
    Application.Undo

    oldValue = Trim$(CStr(Target.Value))

    ' Теперь отключаем события перед возвратом нового значения
    Application.EnableEvents = False

    ' Возвращаем новое значение
    Target.Value = newValue

    ' Если фактически ничего не изменилось
    If StrComp(oldValue, newValue, vbTextCompare) = 0 Then
        GoTo SafeExit
    End If

    ' Получаем уникальный ID из столбца A
    objectID = Me.Cells(Target.Row, ID_COLUMN).Value

    If Len(Trim$(CStr(objectID))) = 0 Then

        MsgBox _
            "Статус изменен, но история не записана." & vbCrLf & vbCrLf & _
            "В строке " & Target.Row & _
            " отсутствует уникальный ID в столбце A.", _
            vbExclamation, _
            "Не указан ID"

        GoTo SafeExit

    End If

    ' Проверяем / создаем служебную структуру
    Set wsHistory = EnsureStructure()

    ' Следующая свободная строка журнала
    historyRow = wsHistory.Cells( _
        wsHistory.Rows.Count, "A").End(xlUp).Row + 1

    If historyRow < 2 Then historyRow = 2

    ' Записываем переход
    With wsHistory

        .Cells(historyRow, "A").Value = objectID
        .Cells(historyRow, "B").Value = oldValue
        .Cells(historyRow, "C").Value = newValue
        .Cells(historyRow, "D").Value = Now

    End With

    ' Пересчитываем количество рабочих дней
    UpdateStatusDays objectID, Target.Row, wsHistory

SafeExit:

    Application.EnableEvents = True
    Exit Sub


ErrorHandler:

    Application.EnableEvents = True

    MsgBox _
        "Ошибка при обработке изменения статуса:" & vbCrLf & vbCrLf & _
        Err.Description, _
        vbExclamation, _
        "Ошибка"

End Sub


Private Function EnsureStructure() As Worksheet

    Dim wsHistory As Worksheet

    ' ---------------------------------------------------------
    ' Ищем лист истории
    ' ---------------------------------------------------------

    On Error Resume Next

    Set wsHistory = _
        ThisWorkbook.Worksheets(HISTORY_SHEET_NAME)

    On Error GoTo 0

    ' ---------------------------------------------------------
    ' Если листа нет — создаем
    ' ---------------------------------------------------------

    If wsHistory Is Nothing Then

        Set wsHistory = ThisWorkbook.Worksheets.Add( _
            After:=ThisWorkbook.Worksheets( _
                ThisWorkbook.Worksheets.Count))

        wsHistory.Name = HISTORY_SHEET_NAME

    End If

    ' ---------------------------------------------------------
    ' Заголовки листа истории
    ' ---------------------------------------------------------

    With wsHistory

        .Cells(1, "A").Value = "ID"
        .Cells(1, "B").Value = "Старый статус"
        .Cells(1, "C").Value = "Новый статус"
        .Cells(1, "D").Value = "Дата изменения"

        .Columns("D").NumberFormat = "dd.mm.yyyy hh:mm:ss"

    End With

    ' ---------------------------------------------------------
    ' Заголовки основной таблицы
    ' ---------------------------------------------------------

    Me.Cells(HEADER_ROW, US_DAYS_COLUMN).Value = _
        "Рабочих дней УС"

    Me.Cells(HEADER_ROW, OKB_DAYS_COLUMN).Value = _
        "Рабочих дней ОКБ"

    Me.Columns(US_DAYS_COLUMN).NumberFormat = "0.00"
    Me.Columns(OKB_DAYS_COLUMN).NumberFormat = "0.00"

    Set EnsureStructure = wsHistory

End Function


Private Sub UpdateStatusDays( _
    ByVal objectID As Variant, _
    ByVal sourceRow As Long, _
    ByVal wsHistory As Worksheet)

    Dim lastRow As Long
    Dim i As Long

    Dim eventID As Variant
    Dim newStatus As String
    Dim nextStatus As String

    Dim startDate As Date
    Dim endDate As Date

    Dim usDays As Double
    Dim okbDays As Double

    lastRow = wsHistory.Cells( _
        wsHistory.Rows.Count, "A").End(xlUp).Row

    ' Идем по истории конкретного ID
    For i = 2 To lastRow

        eventID = wsHistory.Cells(i, "A").Value

        If CStr(eventID) = CStr(objectID) Then

            newStatus = _
                Trim$(CStr(wsHistory.Cells(i, "C").Value))

            ' Нас интересуют только УС и ОКБ
            If StrComp(newStatus, "УС", vbTextCompare) = 0 _
            Or StrComp(newStatus, "ОКБ", vbTextCompare) = 0 Then

                startDate = wsHistory.Cells(i, "D").Value

                ' Ищем следующее изменение этого же ID
                endDate = GetNextChangeDate( _
                    wsHistory, _
                    objectID, _
                    i + 1, _
                    lastRow)

                ' Если следующего изменения нет,
                ' статус считается текущим до настоящего момента
                If endDate = 0 Then
                    endDate = Now
                End If

                If StrComp( _
                    newStatus, _
                    "УС", _
                    vbTextCompare) = 0 Then

                    usDays = usDays + _
                        BusinessDaysBetween(startDate, endDate)

                ElseIf StrComp( _
                    newStatus, _
                    "ОКБ", _
                    vbTextCompare) = 0 Then

                    okbDays = okbDays + _
                        BusinessDaysBetween(startDate, endDate)

                End If

            End If

        End If

    Next i

    Me.Cells(sourceRow, US_DAYS_COLUMN).Value = usDays
    Me.Cells(sourceRow, OKB_DAYS_COLUMN).Value = okbDays

End Sub


Private Function GetNextChangeDate( _
    ByVal wsHistory As Worksheet, _
    ByVal objectID As Variant, _
    ByVal startRow As Long, _
    ByVal lastRow As Long) As Date

    Dim i As Long

    For i = startRow To lastRow

        If CStr(wsHistory.Cells(i, "A").Value) = _
           CStr(objectID) Then

            GetNextChangeDate = _
                wsHistory.Cells(i, "D").Value

            Exit Function

        End If

    Next i

    GetNextChangeDate = 0

End Function


Private Function BusinessDaysBetween( _
    ByVal startDate As Date, _
    ByVal endDate As Date) As Double

    Dim currentDate As Date

    Dim dayStart As Date
    Dim dayEnd As Date

    Dim intervalStart As Date
    Dim intervalEnd As Date

    Dim totalDays As Double

    ' Защита от некорректного интервала
    If endDate <= startDate Then
        BusinessDaysBetween = 0
        Exit Function
    End If

    currentDate = Int(startDate)

    Do While currentDate <= Int(endDate)

        ' Понедельник = 1 ... Пятница = 5
        If Weekday(currentDate, vbMonday) <= 5 Then

            dayStart = currentDate
            dayEnd = currentDate + 1

            If startDate > dayStart Then
                intervalStart = startDate
            Else
                intervalStart = dayStart
            End If

            If endDate < dayEnd Then
                intervalEnd = endDate
            Else
                intervalEnd = dayEnd
            End If

            If intervalEnd > intervalStart Then

                totalDays = totalDays + _
                    (intervalEnd - intervalStart)

            End If

        End If

        currentDate = currentDate + 1

    Loop

    BusinessDaysBetween = totalDays

End Function