Суперфильтр на VBA
Стандартный Автофильтр для выборки из списков - вещь, безусловно, привычная и надежная. Но для создания сложных условий приходится выполнить не так уж мало действий. Например, чтобы отфильтровать значения попадающие в интервал от 100 до 200, необходимо развернуть список Автофильтра мышью, выбрать вариант Условие (Custom), а в новых версиях Excel: Числовые фильтры - Настраиваемый фильтр (Number filters - Custom filter). Затем в диалоговом окне задать два оператора сравнения, значения и логическую связку (И-ИЛИ) между ними:
Не так уж и долго, скажут некоторые. Да, но если в день приходится повторять эту процедуру по нескольку десятков раз? Выход есть - альтернативный фильтр с помощью макроса, который будет брать значения критериев отбора прямо из ячеек листа, куда мы их просто введем с клавиатуры. По сути, это будет похоже на расширенный фильтр, но работающий в реальном времени. Чтобы реализовать такую штуку, нам потребуется сделать всего два шага:
Шаг 1. Именованный диапазон для условий
Сначала надо создать именованный диапазон, куда мы будем вводить условия, и откуда макрос их будет брать. Для этого можно прямо над таблицей вставить пару-тройку пустых строк, затем выделить ячейки для будущих критериев (на рисунке это A2:F2) и дать им имя Условия, вписав его в поле имени в левом верхнем углу и нажав клавишу Enter. Для наглядности, я выделил эти ячейки желтым цветом:
Шаг 2. Добавляем макрос фильтрации
Теперь надо добавить к текущему листу макрос фильтрации по критериям из созданного диапазона Условия. Для этого щелкните правой кнопкой мыши по ярлычку листа и выберите команду Исходный текст (Source text). В открывшееся окно редактора Visual Basic надо скопировать и вставить текст вот такого макроса:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim FilterCol As Integer
Dim FilterRange As Range
Dim CondtitionString As Variant
Dim Condition1 As String, Condition2 As String
If Intersect(Target, Range("Условия")) Is Nothing Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
'определяем диапазон данных списка
Set FilterRange = Target.Parent.AutoFilter.Range
'считываем условия из всех измененных ячеек диапазона условий
For Each cell In Target.Cells
FilterCol = cell.Column - FilterRange.Columns(1).Column + 1
If IsEmpty(cell) Then
Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol
Else
If InStr(1, UCase(cell.Value), " ИЛИ ") > 0 Then
LogicOperator = xlOr
ConditionArray = Split(UCase(cell.Value), " ИЛИ ")
Else
If InStr(1, UCase(cell.Value), " И ") > 0 Then
LogicOperator = xlAnd
ConditionArray = Split(UCase(cell.Value), " И ")
Else
ConditionArray = Array(cell.Text)
End If
End If
'формируем первое условие
If Left(ConditionArray(0), 1) = "<" Or Left(ConditionArray(0), 1) = ">" Then
Condition1 = ConditionArray(0)
Else
Condition1 = "=" & ConditionArray(0)
End If
'формируем второе условие - если оно есть
If UBound(ConditionArray) = 1 Then
If Left(ConditionArray(1), 1) = "<" Or Left(ConditionArray(1), 1) = ">" Then
Condition2 = ConditionArray(1)
Else
Condition2 = "=" & ConditionArray(1)
End If
End If
'включаем фильтрацию
If UBound(ConditionArray) = 0 Then
Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1
Else
Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1, _
Operator:=LogicOperator, Criteria2:=Condition2
End If
End If
Next cell
Set FilterRange = Nothing
Application.ScreenUpdating = True
End Sub
Все.
Теперь при вводе любых условий в желтые ячейки нашего именованного диапазона тут же будет срабатывать фильтрация, отображая только нужные нам строки и скрывая ненужные:
Как и в случае с классическими Автофильтром (Filter) и Расширенным фильтром (Advanced Filter), в нашем фильтре макросом можно смело использовать символы подстановки:
- * (звездочка) - заменяет любое количество любых символов
- ? (вопросительный знак) - заменяет один любой символ
и операторы логической связки:
- И - выполнение обоих условий
- ИЛИ - выполнение хотя бы одного из двух условий
и любые математические символы неравенства (>,<,=,>=,<=,<>).
При удалении содержимого ячеек желтого диапазона Условия автоматически снимается фильтрация с соответствующих столбцов.
P.S.
- Если у вас Excel 2007 или 2010 не забудьте сохранить файл с поддержкой макросов (в формате xlsm), иначе добавленный макрос умрет.
- Данный макрос не умеет работать с "умными таблицами"
Ссылки по теме
- Что такое макросы, куда вставлять код макроса на VBA, как их использовать?
- Умные таблицы Excel 2007/2010
- Расширенный фильтр и немного магии
AutoFilter.Sort.SortFields.Clear AutoFilter.Sort.SortFields.Add Key:=Range _ ("E4:E1403"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End WithТолько замените в нем адрес сортируемого столбца на свой.
Вместо
нужно вставить
Set FilterRange = Range("Таблица1")"Таблица1" - имя нашей умной таблицы.
ПС, я не программист, т.ч. буду признателен, если кто проверит..
Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub End If Dim Cell As Range Dim Table As ListObject Dim ConditionString As Variant, ConditionArray As Variant Dim FilterCol As Integer Dim LogicOperator As Byte Dim Condition1 As String, Condition2 As String Set Table = ActiveWorkbook.Worksheets("bb").ListObjects("ff") On Error GoTo ErrHandl With Application: .ScreenUpdating = False .Calculation = xlCalculationManual End With For Each Cell In Target.Cells FilterCol = Cell.Column - Table.Range.Columns(1).Column + 1 If IsEmpty(Cell) Then Target.Parent.Range(Table.Range.Address).AutoFilter Field:=FilterCol Else If InStr(1, UCase(Cell.Value2), " ИЛИ ") > 0 Then LogicOperator = xlOr ConditionArray = Split(UCase(Cell.Value2), " ИЛИ ") Else If InStr(1, UCase(Cell.Value2), " И ") > 0 Then LogicOperator = xlAnd ConditionArray = Split(UCase(Cell.Value2), " И ") Else ConditionArray = Array(Cell.Text) End If End If If Left(ConditionArray(0), 1) = "<" _ Or Left(ConditionArray(0), 1) = ">" Then Condition1 = ConditionArray(0) Else Condition1 = "=" & ConditionArray(0) End If If UBound(ConditionArray) = 1 Then If Left(ConditionArray(1), 1) = "<" _ Or Left(ConditionArray(1), 1) = ">" Then Condition2 = ConditionArray(1) Else Condition2 = "=" & ConditionArray(1) End If End If If UBound(ConditionArray) = 0 Then Target.Parent.Range(Table.Range.Address).AutoFilter Field:=FilterCol, _ Criteria1:=Condition1 Else Target.Parent.Range(Table.Range.Address).AutoFilter Field:=FilterCol, _ Criteria1:=Condition1, Operator:=LogicOperator, Criteria2:=Condition2 End If End If Next Cell Set Cell = Nothing Set ConditionString = Nothing Set ConditionArray = Nothing Set Table = Nothing With Application: .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With Exit Sub ErrHandl: Set Cell = Nothing Set ConditionString = Nothing Set ConditionArray = Nothing Set Table = Nothing With Application: .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("номер ячейки, например G2")) Is Nothing Then '
If Target.Value = "Введите текст для поиска::" Then Exit Sub ' если пользователь ничего не ввёл, то выходим
If Target.Value = "" Then
Target.Value = "Введите текст для поиска:" ' подсказка в ячейке
shCandidates.Range("tblSites").AutoFilter Field:=6 ' очистить фильтр (№ колонки в "умной" таблице tblSites
Exit Sub
End If
With shCandidates ' имя листа, на котором размещена "умная" таблица
.Range("tblSites").AutoFilter Field:=6, Criteria1:="*" & shCandidates.Range("G2").Value & "*" ' фильтр по подстроке
.Range("G2").Select ' возврат фокуса в ячейку поиска/фильтра
End With
End If
End Sub
При необходимости фильтрации более чем по одному полю, необходимо прописать подобную процедуру для каждого из них
а после 59-й строки обратно защиту ставить:
Получаю ошибку "excpected end sub"
Что не так?
Спасибо
'ов или забыли End Sub дописать в конце макроса.
Сделал все как в Вашей инструкции. При фильтрации макрос выдает ошибку "Compile error. Syntax error." при этом сразу открывает редактор и выделяет красным 52, 53 строки макроса.
52 Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1, _
53 Operator:=LogicOperator, Criteria2:=Condition2
Когда наводитесь мышью на код макроса на странице, то в правом верхнем углу появляются значки. Вам нужен крайний левый.
Или просто скачайте мой пример в заголовке статьи и возьмите код макроса оттуда.
Спасибо, все заработало!
ИЛИ - выполнение хотя бы одного из двух условий
а возможно сделать выполнение нескольких условий?
январь или март или *брь
Скрипт и вправду достоин множественных похвал,
но к делу...
Видимо, выражу общую заинтересованность отписавшихся выше , , а также свою в следующем вопросе:
Как возможно доработать макрос Фильтра, до макроса Поиска по определённым колонкам прайс-листа?
На данный момент макрос может выполнять функцию поиска при условии, что перед искомым текстом, а также после него будут поставлены символы подстановки *(звездочка). Поиск будет производится по колонке, в которой и ввели запрос.
А хотелось бы, чтобы всё осталось точно также, НО:
- чтобы звездочки вручную ставить не пришлось(т.е. немного обмануть макрос, чтоб он думал, что * уже стоят);
- чтобы текст искал не только по своей колонке, а ещё и по нескольким соседним колонкам.
Тогда, выделив всего одну ячейку под будущие критерии, и дав ей имя Условие, можно будет Искать введенные значения во 2,3,4 колонках (расширив в три раза диапазон данных списка).
Заранее очень признателен за Ваш ответ, понимая, что макрос может быть подвергнут значительным изменениям, что потребует некоторых усилий.
когда он один на листе, работает прекрасно, но в сочетание с несколькими макросами или этот не работает, или другие, в зависимости в каком порядке ставлю... ни как не могу понять в чём дело.
зарание спасибо.
If Intersect(Target, Range("Условия")) Is Nothing Then GoTo 1 ... ... 1: тут начинается следущий макроснапример мы ввели фильтрацию по нескольким условиям(овощи,январь, Москва), выдались результаты...фамилии разные, но нам еще нужно, если нашелся Петров , то выдать все данные Петрова ниже, а не только по данному фильтру, и также со всеми фамилиями.
Фильтр ОЧЕНЬ удобный. А можно ли сделать так что бы он искал не точно введенное значение, а все ячейки которые содержат введенный фрагмент?
Спасибо!
Спасибо за умный макрос!
У меня такая задачка.
В моем файле 4 выпадающих списка.
В именованном диапазоне "Условия" у меня только один параметр ">0", который установлен по умолчанию и меняться не будет.
Что необходимо поменять/дописать в макросе, чтобы фильтрация осуществлялась автоматически каждый раз при выборе данных в любом из выпадающих списков?
запрос1 запрос2 а обработался как *запрос1* и *запрос2* (нужно для столбцов B и С)?
Методом проб и ошибок заменил в строке 38 и 45 "=" на "*" , запрос стал обрабатываться со звездочкой, а как сделать его двойным?
Что ему не нравится?
Столкнулся с проблемой:
при вставке/удалении/очистке столбца в пределах именованного диапазона Эксель зависает,
я так понимаю, что макрос запускается и зацикливается.
Нельзя-ли это исправить?
Подскажите как изменить макрос чтобы один столбец накладывать более 2 условий ?
Классный макрос, но хотелось бы узнать можно ли его изменить так, чтобы условия вводить в одном столбце, но в разных строках, а фильтр работал по скрытым столбцам с этими данными?
Огромное Вам спасибо за Вашу работу! Бесконечно Вам благодарен Вам за те знания, которые я получаю у Вас на сайте!
Скажите, пожалуйста, а возможно ли модифицировать данный макрос до возможности фильтровать данные по условиям заданным в разных столбцах ?
Проблему конечног может решить макрос из темы "Расширенный фильтр и немного магии", но он не обладает возможностью текущего (задавать несколько условий для одного поля в одной ячейке используя операторы и/или)
Вот если бы возможности каждого из макросов "скрестить", то мы получим 100% идеалный фильтр :
Спасибо!
Есть вопрос:
данные в фильтруемую ячейку попадают по ссылке. И для того, чтобы фильтр обновился, необходимо обязательно поставить туда мышку и нажать enter. иначе данные не обновляются.
Подскажите, пожалуйста, возможно ли это сделать автоматическим и как?)
Заранее благодарю еще и за это)
Подскажите, из-за чего Суперфильтр работает частично?
Я ВСЕ СДЕЛАЛ как написано на Статье.
- Создал "Именованный диапазон для условий"
- Добавил "Макрос Фильтрации".
Пользуюсь Англ. версией Mic Office, При клике на ярлык Листа, не нашел пункт Исходный текст/Source text, поэтому Использовал
пункт "View Code".
- Файл сохранил как .xlsm
Но, непонятно почему, Фильтр работает частично. Он не фильтрует Значения в формате Number Decimal.
На скринах видно.
И после, попытка отфильтровать данные Number Decimal
Надеюсь на Вашу помощь! Потому что Сам не смог понять Причину такого Бага.
Может надо что-то дописать, или изменить в самом Макросе...
Хотя в примере есть же - КОЛОНКИ с числовыми данными, которые фильтруются.
Я уже выделял колонки и ставил формат - General и всеравно не отибрает данные Decimal, только целые отбирает. Если фильровать к 3 4 5 и так далее, а если фильтровать 2,32 2,45 3,33 просто "схловывает" базу (как на скрине)
Спасибо за помощь.
Очень классный макрос!
Подскажите пожалуйста:
- после защиты листа (ActiveSheet.Protect Password:="123"), на защищенном листе перестает работать текстовый автофильтр (даже если перед защитой вручную ставить "использование автофильтра на защищенном листе", он почему то ее сбрасывает). Как макросу дать понять, что бы при защите он не блокировал использование автофильтра? Заранее благодарю!
Что нужно изменить?
Подскажите пожалуйста, очень нужно
Скажите, можно как-либо через макрос реализовать функцию, аналогичную FILTER в google sheets?
Подскажите, пожалуйста, можно ли в одной ячейке указывать более двух условий?
Судя по экспериментам, которые я проводила, более двух условий не работают.
Дело в том, что мне необходимо в текстовых полях искать различные словосочетания в нескольких комбинациях ИЛИ и И
Быть может есть другой способ для поиска?
Заранее спасибо за ответ
- Скачал пример (вверху этой странички).
- Внизу создал копию листа "Заказы" - "Заказы (2)".
- На втором листе в ячейке А2 создал ссылку на ячейку А2 первого листа: =Заказы!А2
- Получаю проблему, что фильтр на втором листе не работает, хотя в ячейке отображается такое же слово, что и на первом листе - "Киви" или "Манго".
Само собой код макроса присутствует в двух экземплярах после копирования Листа - каждому Листу свой код (одинаковый). Это я уже понял.Но как же заставить, чтобы при изменении текста фильтра на первом листе менялся и работал фильтр на других листах, созданных копированием первого листа?
Но у меня вылезла 1 проблема. Подскажите, если кто знает.
Фильтрую по двум столбцам. В одном из столбцов 3 условия через "или" - "в работе или не подтверждено или у проектного офиса"
Почему-то в выборку не попадают позиции с "не подтверждено"
При этом(!) если удалить одно из условий, например оставить "не подтверждено или у проектного офиса" Или "в работе или не подтверждено", то " Не подтверждено" Начинает попадать в выборку.
Как-будто макрос не хочет считать 3 значения в условии, а останавливается на двух.
Кто-нибудь сталкивался с этим?
Заранее спасибо.
Возможно ли доработать макрос, до поиска по более чем двум критериям в ячейке?