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

Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FRM_Search_arr: FRM_Search_arr = 0
    If Len(FRM_Search_Mask) Then
        Me.tb_mask.Value = FRM_Search_Mask
    Else
        ArrayFilterByMask
    End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
FRM_Search_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$

mask = Me.tb_mask.Value
    For Each x In arrSym
        If InStr(mask, x) Then mask = Replace(mask, x, "")
    Next x

MaskReplace = UCase(mask)
End Function
'===========================================================================================
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&

Me.bC.Visible = False
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out

    If Me.bT.Value = True Then
        mask = MaskReplace & "*"
    Else
        mask = "*" & MaskReplace & "*"
    End If

Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1

    For Each x In arrFull
        If UCase(x) Like mask Then n = n + 1: arr(n) = x
    Next x

If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr

out:
Me.tb_count.Value = Me.lb.ListCount
Me.tb_mask.SetFocus
If Me.lb.ListCount > 0 Then Me.bC.Visible = True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub bC_Click()
Dim arr(), x, i&, n&

ReDim arr(UBound(arrFull))

    For i = 0 To Me.lb.ListCount - 1
        If Me.lb.Selected(i) Then arr(n) = Me.lb.List(i): n = n + 1
    Next i

    If n = 0 Then
        If Me.lb.MultiSelect = fmMultiSelectSingle Then MsgBox "При вызове формы для одиночного выделения нельзя сформировать список из всего отфильтрованного!", vbExclamation, "ПУСТО": Exit Sub
        If MsgBox("Ничего не выбрано…" & vbLf & "Сформировать список из ВСЕГО ОТФИЛЬТРОВАННОГО" & vbLf & "(" & Me.lb.ListCount & " элементов)?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
        ReDim arr(0 To UBound(arrFull)): n = 0
        For Each x In Me.lb.List
            arr(n) = x: n = n + 1
        Next x
    End If

fin: ReDim Preserve arr(n - 1): FRM_Search_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FRM_Search_arr(0)
FRM_Search_arr(0) = lb.List(lb.ListIndex)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()

    If Me.bT.Value = True Then
        Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
    Else
        Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
    End If

ArrayFilterByMask
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 13 Then
        If Me.lb.ListCount = 0 Then MsgBox "Список пуст!", vbExclamation, "ПУСТО": Exit Sub
        bC_Click
    End If
If KeyAscii = 27 Then Unload Me
End Sub

Option Explicit
Option Private Module
'===========================================================================================
Public FRM_Search_arr, FRM_Search_Mask$
'===========================================================================================
Function FRM_Search_Start(tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
If Not DontSort Then FRM_Search_Sort tmpArr1x, 0, UBound(tmpArr1x)
FRM_Search_arr = tmpArr1x: Erase tmpArr1x

If Multy Then FRM_Search.lb.MultiSelect = fmMultiSelectExtended
FRM_Search.Show

If Not IsArray(FRM_Search_arr) Then Exit Function
tmpArr1x = FRM_Search_arr: Erase FRM_Search_arr
FRM_Search_Start = True
End Function
'===========================================================================================
Sub FRM_Search_Sort(arr1x(), l&, u&)
Dim i&, j&, x, y

i = l: j = u: x = arr1x((l + u) \ 2)

        Do
            Do While arr1x(i) < x: i = i + 1: Loop
            Do While x < arr1x(j): j = j - 1: Loop
            If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
        Loop Until i > j

If l < j Then FRM_Search_Sort arr1x, l, j
If i < u Then FRM_Search_Sort arr1x, i, u
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

' преобразуем
Application.ScreenUpdating = False
rngCol.NumberFormat = "@"

On Error Resume Next
rng.AutoFilter Field:=cl.Column, Criteria1:=arr1x, Operator:=xlFilterValues
If Err Then GoTo er Else Err.Clear
i = rngCol.SpecialCells(xlVisible).Count
If Err Or i = 0 Then GoTo er Else On Error GoTo 0
NumberFormat_Return rngCol, NF
GoTo fin

er:
MsgBox "Диапазон не отфильтрован!", vbCritical, "FILE_Range_FilterActiveColumn"
NumberFormat_Return rngCol, NF

fin: Application.ScreenUpdating = True
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