Option Explicit
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal target As Range, Cancel As Boolean)
Cancel = True: FRM_Search_FindInActiveColumn.Start
End Sub

Option Explicit
Const delim$ = "  " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Sub Start()
Dim sh As Worksheet, rng As Range, rngCol As Range, cl As Range
Dim x, arr, arr1x(), NF$, lr&, i&

' получаем уникальные данные столбца и диапазон для фильтрации
Set sh = ActiveWorkbook.ActiveSheet: Set cl = ActiveCell
On Error Resume Next: Set x = sh.ListObjects(1): On Error GoTo 0

    If TypeName(x) <> "ListObject" Then
        Set rng = sh.UsedRange
        lr = sh.Cells(Rows.Count, cl.Column).End(xlUp).Row
        If cl.Row > lr Then Exit Sub
    Else
        Set rng = x.Range
        If Intersect(cl, rng) Is Nothing Then Exit Sub
        lr = x.ListRows.Count + 1
    End If

If rng.Cells(1, 1).Row <> 1 Or rng.Cells(1, 1).Column <> 1 Then MsgBox "Область данных должна начинаться с ПЕРВОЙ ячейки листа!", vbExclamation, "ОШИБКА РАСПОЛОЖЕНИЯ ДАННЫХ": Exit Sub
If lr < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub

' получаем столбец и его данные, получаем список найденного по форме
Set rngCol = sh.Cells(2, cl.Column).Resize(lr - 1).SpecialCells(xlVisible)
NF = cl.NumberFormat: x = NumberFormat_Replace(cl)
arr1x = RangeToArray1x(rngCol, x)
If Not FRM_Search_Start(arr1x, True) Then Exit Sub

    If Len(x) Then  ' если нужно было учитывать формат, то берём из каждого элемента левую часть до разделителя и преобразуем в текстовый
        For i = 0 To UBound(arr1x)
            arr1x(i) = CStr(Left$(arr1x(i), InStr(arr1x(i), delim) - 1))
        Next i
    Else            ' если разделителя нет, то просто преобразуем в текстовый
        For i = 0 To UBound(arr1x)
            arr1x(i) = CStr(arr1x(i))
        Next i
    End If

' до этого момента это был код фильтра активного столбца
    If UBound(arr1x) = 0 Then
        If IsNumeric(arr1x(0)) Then ActiveCell.Value2 = --arr1x(0) Else ActiveCell.Value2 = arr1x(0)
    Else
        ActiveCell.Value2 = Join(arr1x, "; ")
    End If
End Sub
'===========================================================================================
Private Function NumberFormat_Replace(cl As Range) As String
Dim NumFormat$: NumFormat = cl.NumberFormat

If NumFormat = "General" Or NumFormat = "@" Then Exit Function

    If IsDate(cl) Then
        If NumFormat Like "*h*" Then NumberFormat_Replace = "yyyy.mm.dd hh-mm-ss" Else NumberFormat_Replace = "yyyy-mm-dd"
        Exit Function
    End If

If NumFormat Like "*h*:*" Then NumberFormat_Replace = "[h]:mm:ss": Exit Function
If NumFormat Like "*0*.*0*" Then NumberFormat_Replace = "# ##0.00": Exit Function
End Function
'===========================================================================================
Private Function RangeToArray1x(ByVal rng As Range, ByVal NumFormat$) As Variant()
Dim dic As New Dictionary, ar As Range
Dim x, arr, i&

    If Len(NumFormat) Then
        For Each ar In rng.Areas
            If ar.Count = 1 Then
                x = ar.Value2 & delim & WorksheetFunction.Text(ar.Value2, NumFormat)
                x = dic.Item(x)
            Else
                arr = ar.Value2
                For Each x In arr
                    x = x & delim & WorksheetFunction.Text(x, NumFormat)
                    x = dic.Item(x)
                Next x
            End If
        Next ar
    Else
        For Each ar In rng.Areas
            If ar.Count = 1 Then
                x = dic.Item(ar.Value2)
            Else
                arr = ar.Value2
                For Each x In arr
                    x = dic.Item(x)
                Next x
            End If
        Next ar
    End If
RangeToArray1x = dic.Keys
End Function
'===========================================================================================
Private Sub NumberFormat_Return(rng As Range, ByVal NumFormat$)
Dim cl As Range

rng.NumberFormat = NumFormat
    For Each cl In rng
        If cl.EntireRow.Hidden Then cl.NumberFormat = NumFormat
    Next cl
End Sub