Ранее создал тему, о форме с поиском и, в качестве примера рассматривал фильтр по активному столбцу. Пришло время вынести этот пример в отдельную тему.
Хотя данная тема и использует форму с поиском из другой моей темы но могут быть отличия в названиях (макросов, модулей, форм и глобальных переменных)
v 1.0 ОСОБЕННОСТИ: • вся фильтрация зашита в один модуль + событие книги для вызова по даблклику на любом листе (1 строка) • сделано в виде отдельной надстройки (форма с кодом + модуль для формы + модуль для фильтрации) • требует, чтобы фильтруемый диапазон содержал шапку и начинался с первой ячейки листа • работает с "умными" таблицами и обычными диапазонами • учитывает формат данных (ikki помог) • работает только с полным (нефильтрованным диапазоном). Если диапазон был отфильтрован, то все фильтры будут сброшены • как использовать: 1.подключить надстройку 2. создать ссылку на надстройку: в редакторе Tools -> Preference поставить галочку напротив PaRADoX_FilterActiveColumn или перетащить мышкой (если выбрать форму запуска в виде макроса на панели задач (кнопка), то ссылка не нужна) 3. запустить макрос фильтрации любым удобным методом. Ссылки есть в v 1.1
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal target As Range, Cancel As Boolean)
Cancel = True: FILE_Range_FilterActiveColumn
End Sub
Модуль для фильтрации
Код
Option Explicit
Option Private Module
Const FFF_delim$ = " " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Sub FILE_Range_FilterActiveColumn()
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
On Error Resume Next: sh.ShowAllData: On Error GoTo 0
Set rngCol = sh.Cells(2, cl.Column).Resize(lr - 1)
NF = cl.NumberFormat: x = NumberFormatReplace(cl)
arr1x = RangeToArray1x(rngCol, x)
If Not FILE_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), FFF_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
Set rng = rngCol.SpecialCells(xlVisible)
If Err Then GoTo er Else On Error GoTo 0
RangeFormatReturn rngCol, NF
Exit Sub
er:
MsgBox "Диапазон не отфильтрован!", vbCritical, "FILE_Range_FilterActiveColumn"
On Error Resume Next: sh.ShowAllData: On Error GoTo 0
rng.AutoFilter
rngCol.NumberFormat = NF
fin: Application.ScreenUpdating = True
End Sub
'===========================================================================================
Private Function NumberFormatReplace(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 NumberFormatReplace = "yyyy.mm.dd hh-mm-ss" Else NumberFormatReplace = "yyyy-mm-dd"
Exit Function
End If
If NumFormat Like "*h*:*" Then NumberFormatReplace = "[h]:mm:ss": Exit Function
If NumFormat Like "*0*.*0*" Then NumberFormatReplace = "# ##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 & FFF_delim & WorksheetFunction.Text(ar.Value2, NumFormat)
x = dic.Item(x)
Else
arr = ar.Value2
For Each x In arr
x = x & FFF_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 RangeFormatReturn(rng As Range, NF$)
Dim cl As Range
rng.NumberFormat = NF
For Each cl In rng
If cl.EntireRow.Hidden = True Then
cl.NumberFormat = NF
ElseIf cl.EntireColumn.Hidden = True Then
cl.NumberFormat = NF
End If
Next cl
End Sub
'===========================================================================================
'===========================================================================================
Последняя актуальная версия надстройки/кода теперь в родительской теме
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Уважаемый, Jack Famous . Установил Вашу надстройку, в модуль книги ( в окне Visual Basic в левой панели в своем файле "встал" на иконку "ЭтаКнига", правой кнопкой мыши выбрал в контекстном меню View Code и в окне справа вставил Ваш код. Свернул окно редактора VB и попробовал фильтровать... Вывалилось окно (в прикрепленном файле). Скажите, пожалуйста, что я делаю не так. Может нужно скопировать и вставить еще модуль фильтрации? Помогите ....
voxik-24, обновил надстройку и инструкцию (читать внимательно и смотреть все ссылки). Тестить пока некогда…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Уважаемый, Jack Famous . Удалось после Ваших дополнительных разъяснений установить надстройку! Но фильтрация происходит в таблице из 45000 строк очень долго...2-3 минуты. Это можно поправить или от чего это зависит?
voxik-24, если формат данных текстовый или общий, должно быть быстрее. Оптимизация впереди Dima S, в первую очередь, это поиск. Поиск по маске. В стандартном фьльтре поиск довольно ограничен (без подробностей). В своей надстройке я пытаюсь совместить нестандартные вещи (кратко говоря)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Уважаемый, Jack Famous . Ждем оптимизацию и быстродействие, но это как я понял, в планах. А на сегодняшний день хорошо было бы если с Вашей настройкой не приходилось каждый раз в других файлах делать лишние движения (туда скопируйте, там отметьте или перетащите....). Если на ее создание Вас вдохновила настройка Николая PLEX, то почему бы не сделать как у него? Я имею ввиду своя панель, на ней кнопкой вызывается форма фильтра и т.д. и не каких танцев - пока настройка подключена, она сразу во всех открывающихся файлах. Я все это к чему... дело Вы задумали очень хорошее, такой фильтрации нет ни в одной надстройке (даже у Гуру Павлова Н.) и многие были бы Вам благодарны за труды.
voxik-24: такой фильтрации нет ни в одной надстройке (даже у Гуру Павлова Н.)
думаю, что она просто задумывалась изначально не такой и свою работу делает прекрасно
Цитата
voxik-24: своя панель, на ней кнопкой вызывается форма фильтра и т.д. и не каких танцев
танцы нужны были только для обеспечения вызова формы по событию книги. Думаю, что можно было бы и это обойти (делать программно, а не ручками), но пока что не до этого. Панель свою создавать ради одной кнопки смысла не вижу, а вывести кнопку на панель быстрого доступа можно и так в пару-тройку шагов…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
ИЗМЕНЕНИЯ: • изменены названия формы и модулей, а также префиксы глобальных переменных • работает даже если фильтр уже стоит (дофильтровка) • фильтрует все форматы (преобразует в общий, фильтрует и возвращает формат как было) • при поиске в форме добавляет к некоторым форматам формат для поиска (например дата и время - это числа и к ним добавляется более понятный формат)
ВАЖНО: по-прежнему не фильтрует числа более 10 знаков (включая целую и дробную часть). Относится и ко времени тоже. Обходить смысла не вижу (не надо) ВЫЗОВ: тут в коде показан пример вызова макроса на событии книги. Хотите вешайте на горячие клавиши, хотите выводите кнопку (ответил в предыдущем посте). А кому лень подключить библиотеку, поставив галочку или перетащив проект, то посмотрите, как это делается программно…
Пример вызова (полный путь) макроса фильтрации из надстройки (событие даблклика в книге)
Код
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
Код формы «FRM_Search»
Код
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
Модуль с макросами для формы «FRM_Search_macro»
Код
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
Модуль фильтрации «FRM_Search_FilterActiveColumn»
Код
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
надстройка проверена. Полностью работает. Файл для теста присутствует. Кода и форм в файле нет, зато есть ссылка на надстройку
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄