Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dat&, per&, r As Range, a, i&, n&, j&, c As Range
    dat = Cells(Rows.Count, 4).End(xlUp).Row
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then
        With ThisWorkbook.Sheets("сводная")
            per = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            Target.Offset(0, -6).Resize(1, 5).Copy .Range("A" & per)
            .Range("A" & per).Resize(1, 5).FormatConditions.Delete
            With .Range("F" & per)
                .Value = Date: .Borders.LineStyle = xlContinuous
            End With
        End With
        Target.Offset(0, -5).Resize(1, 6).ClearContents
        Set c = Target
        Do
            Set c = c.Offset(-1)
        Loop While c.Interior.ColorIndex <> 6
        Set r = Cells(c.Row, 4).Offset(1).Resize(8, 6)
        a = r.Value: n = 0
        For i = 1 To UBound(a)
            If a(i, 2) <> "" Then
                n = n + 1
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            End If
        Next
        r.ClearContents: r.Range("a1").Resize(n, UBound(a, 2)) = a
    End If
End Sub