Sub ArrUniqSort()
Dim Uniq As New Collection, i&, ii&, iii&, iiii&, y&, n&, s, b As Range, a&
Dim x, tbl, arr, lstr&, c&
Application.ScreenUpdating = False
lstr = Cells(Rows.Count, 1).End(xlUp).Row
c = Application.WorksheetFunction.CountIf(Range("F1:F" & lstr), "Уникальное")
With Worksheets(1).Range("F1:F" & lstr)
    Set b = .Find("Уникальное", , xlValues, xlPart)
    If Not b Is Nothing Then
        For i = 1 To c
            a = b.Row
            Set b = .FindNext(b)
            If i = c Then
               Set arr = Range("A" & a & ":F" & lstr)
            Else
                Set arr = Range("A" & a & ":F" & b.Row - 1)
            End If
            For n = 1 To 5 ' дапазон столбцов, где ищем уникальные
                For ii = 1 To arr.Rows.Count ' дапазон строк, где ищем уникальные
                On Error Resume Next
                    Uniq.Add arr(ii, n), CStr(arr(ii, n)) ' создаём item уникальных
                Next
            Next
            ReDim arr(1 To Uniq.Count)
            For iii = 1 To Uniq.Count
                arr(iii) = Uniq(iii) 'из item переводим уникальные в value
            Next
            On Error Resume Next
            With New Collection 'создание коллекции для сортировки value
                For Each x In arr
                    If Len(x) > 0 Then 'пустые значения игнорируем
                        If IsEmpty(.Item(x)) Then 'пустые значения игнорируем
                            For iiii = 1 To .Count
                                If x < .Item(iiii) Then Exit For
                            Next
                            If iiii > .Count Then
                                .Add x, x
                            Else
                                .Add x, x, Before:=iiii 'сортировка по алфавиту
                            End If
                        End If
                    End If
                Next
                ReDim tbl(1 To 1, 1 To .Count)
                For iiii = 1 To .Count
                    tbl(i, iiii) = .Item(iiii)
                Next
                Sheets("готово").Range("A" & i).Resize(1, .Count).Value = tbl
            End With
        Next
    End If
End With
Application.ScreenUpdating = True
End Sub