Все уникальные значения по заданному критерию

[Aswerd]

Добрый день!
Нашел в свободном доступе макрос «Extract_Unique_for_Criteria()» ,который позволяет вывести все уникальные значения по заданному критерию (В данном случае из столбца B, начиная с ячейки B2 в столбец D, начиная с ячейки D3)
Возникла необходимость «протянуть» данный макрос по горизонтали ,чтобы он выводил уникальные значения из того же диапазона (столбец B, начиная с ячейки B2) но уже по другому критерию (vCriteria = [E2].Value) в ячейку E3 и т.д.. Диапазон критериев очень большой ( B2 : NZ2) и для каждого критерия должны быть выведены уникальные значения из столбца B,соответсвенно, выведенные в ячейки D3,E3,F3,G3,H3,…….NZ3)

Код представлен ниже ,автора, к сожалению не знаю .
Прошу помощи с доработкой макроса .


Код:
Sub Extract_Unique_for_Criteria()
Dim rCell As Range, avArr, li As Long, vCriteria
ReDim avArr(1 To Rows.Count, 1 To 1)
'Запоминаем критерий
vCriteria = [D2].Value
With New Collection
On Error Resume Next
For Each rCell In Range("B2", Cells(Rows.Count, 2).End(xlUp))
If rCell.Offset(, -1).Value = vCriteria Then
'Cells(Rows.Count, 2).End(xlUp) – определяет последнюю заполненную ячейку в столбце B
.Add rCell.Value, CStr(rCell.Value)
If Err = 0 Then
li = li + 1: avArr(li, 1) = rCell.Value
Else: Err.Clear
End If
End If
Next
End With
If li Then [d3].Resize(li).Value = avArr

End Sub

[Казанский]

Aswerd, вывод уникальных по критерию можно сделать весьма элегантно с помощью Расширенного фильтра. Приложите образец данных в файле xls/xlsx.

[Aswerd]

Казанский, спасибо! Не получилось загрузить файл на форум.Пришлось сбросить на почту ,указанную в Вашем профиле.Буду признателен за любую помощь.