Option Base 1
Option Explicit

Function Spisok(TopLeft As Range, FieldName As Range)

'TopLeft- адрес верхней левой ячейки табл ( напр. Range("A1")
'FieldName адрес ячейки с именем столбца под фильтр ( напр. Range("В1")


Dim i As Integer, j As Integer, r As Integer
Dim MeAr()
Dim CurCell As Range, NextCell As Range

With TopLeft
r = .CurrentRegion.Rows.Count ' к-во строк в табл
.Sort Key1:=FieldName, Header:=xlGuess 'сорт по полю под фильр
End With
Set CurCell = FieldName.Offset(1, 0)
Set NextCell = CurCell.Offset(1, 0)
ReDim MeAr(r) ' опр размерность массива
For i = 1 To r - 1
If CurCell.Value <> NextCell.Value Then ' при каждом изм. добавляем _
массив
j = j + 1
MeAr(j) = CurCell.Value
End If
Set CurCell = NextCell
Set NextCell = CurCell.Offset(1, 0)

Next
Spisok = MeAr()
End Function