Option Explicit

Sub Extract_Unique_for_Criteria()
    Dim rCell As Range, avArr, li As Long, vCriteria, wsh As Worksheet
    ReDim avArr(1 To Rows.Count, 1 To 1)
    vCriteria = [D1].Value
    Set wsh = ThisWorkbook.Worksheets("Лист 1")
    With New Collection
        On Error Resume Next
        For Each rCell In wsh.Range("J2", wsh.Cells(wsh.Rows.Count, 10).End(xlUp))
            If rCell.Offset(, -7).Value = vCriteria Then
                .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 [d2].Resize(li).Value = avArr
End Sub