Sub Test4()
    Dim Sh As Worksheet, Key$, A(), Count&
    Set Sh = ActiveSheet
    LastRow = Sh.Cells(Sh.Rows.Count, 4).End(xlUp).Row
    Set List = CreateObject("scripting.dictionary")
    dx = Sh.Range("A1:D" & LastRow)
    Count = 0
    For n = 1 To UBound(dx)
        Key = dx(n, 4)
        If Key = "Ред" Then
            Count = Count + 1
            List.Item(Count) = Array(n + 1, n + 1)
        Else
            If Count > 0 Then
                A = List.Item(Count)
                A(1) = n
                List.Item(Count) = A
            End If
        End If
    Next
    Items = List.Items
    For n = 0 To List.Count - 1
        A = Items(n)
        rowStart = A(0)
        rowEnd = A(1)
        Key = ""
        For i = rowStart To rowEnd
            If dx(i, 4) = 1 Then
                Key = IIf(Key = "", dx(i, 3), Key & "," & dx(i, 3))
            End If
        Next
        Sh.Cells(rowStart, 6) = Key
    Next
End Sub

'от doober
    Dim rng2 As Range, Aa(), Sh2 As Worksheet
    Set rng2 = Selection
    Set Sh2 = rng2.Parent
    RowStart& = rng2(1, 1).Row
    dx = rng2
    Set List = CreateObject("scripting.dictionary")
    For n2 = 1 To UBound(dx)
    Key$ = dx(n2, 1)
    If Key <> "" Then   'пробелы игнорируем
    If n2 = UBound(dx) Then
    Keys = Split(Key, ", ")   'раскладываем в нижней с запятой пробелом
    For Each Key_ In Keys
    If List.Exists(Key_) Then
    Aa = List.Item(Key_)
    paralast = UBound(Aa) + 1
    ReDim Preserve Aa(paralast)
    Aa(paralast) = n2 - 1 + RowStart
    List.Item(Key_) = Aa
    Else
    List.Item(Key_) = Array(n2 - 1 + RowStart)
    End If
    Next
    Else
    If List.Exists(Key) Then
    Aa = List.Item(Key)
    paralast = UBound(Aa) + 1
    ReDim Preserve Aa(paralast)
    Aa(paralast) = n2 - 1 + RowStart
    List.Item(Key) = Aa
    Else
    List.Item(Key) = Array(n2 - 1 + RowStart)
    End If
    End If
    End If
    Next
    Set rng2 = Nothing
    Items = List.Items
    For n2 = 0 To List.Count - 1
    Aa = Items(n2)
    For i2 = 1 To UBound(Aa) - 1
    If rng2 Is Nothing Then
    Set rng2 = Sh2.Cells(Aa(i2), 1)
    Else
    Set rng2 = Union(rng2, Sh2.Cells(Aa(i2), 1))
    End If
    Next
    Next
    If Not rng2 Is Nothing Then
    rng2.EntireRow.Delete
    End If