|
Вариант II.
|
If Not Worksheets(1).AutoFilter Is Nothing Then
MsgBox "Автофильтр установлен"
Else
MsgBox "Автофильтр не установлен"
End If |
Особенности Microsoft Excel 2003
В этой версии появился новый об'ект ListObject, который переводчики
назвали "список", а в России за ним закрепился (правда после выхода 2007)
другой термин "умная таблица". И у этого списка тоже есть свой автофильтр,
кнопки которого появляются на экране, после выделения любой из ячеек этой
таблицы. Поэтому теперь, наличие/отсутствие автофильтра желательно
проверять не только в рабочем листе, но и в таких списках.
|
Dim iListObject As ListObject
For Each iListObject In Worksheets(1).ListObjects
If iListObject.ShowAutoFilter = True Then
MsgBox "Автофильтр установлен"
Else
MsgBox "Автофильтр не установлен"
End If
Next |
Ответ :
If Worksheets(1).FilterMode = True Then
MsgBox "В рабочем листе применён фильтр"
Else
MsgBox "В рабочем листе не применён фильтр"
End If | |
Если необходимо проверить применение конкретного фильтра, то :
| If Worksheets(1).FilterMode = True Then
MsgBox "В рабочем листе применён " & _
IIf(Worksheets(1).AutoFilterMode = True, _
"Автофильтр", "Расширенный фильтр")
Else
MsgBox "В рабочем листе не применён фильтр"
End If |
Особенности Microsoft Excel 2007
Если необходимо узнать, применён ли фильтр в каждой
"умной таблице", то можно просто перебрать их в цикле и использовать
свойство FilterMode.
| Dim iListObject As ListObject
For Each iListObject In Worksheets(1).ListObjects
If iListObject.ShowAutoFilter = True Then
If iListObject.AutoFilter.FilterMode = True Then
MsgBox "Таблица отфильтрована"
Else
MsgBox "В таблице не применён фильтр"
End If
End If
Next |
Ответ :
If Worksheets(1).AutoFilterMode = True Then
Set iFilterRange = Worksheets(1).AutoFilter.Range
MsgBox "Адрес диапазона с автофильтром " & iFilterRange.Address
End If |
Ответ :
If Worksheets(1).AutoFilterMode = True Then
iAllCountOfRows = Worksheets(1).AutoFilter.Range.Rows.Count
MsgBox "Общее количество строк в автофильтре " & iAllCountOfRows
End If |
Примечание : Строки, которые являются частью заголовка таблицы,
иначе называемой шапкой, также участвуют в подсчёте.
Ответ :
If Worksheets(1).AutoFilterMode = True Then
If Worksheets(1).FilterMode = True Then
iCountOfRows = Worksheets(1).AutoFilter.Range.Columns(1).SpecialCells(xlVisible).Count
MsgBox "Количество отфильтрованных строк " & iCountOfRows - 1
End If
End If | |
| With ThisWorkbook.Worksheets(1) 'Workbooks(...)
If .AutoFilterMode = True And .FilterMode = True Then
With .AutoFilter.Range
iCountOfRows = .Columns(1).SpecialCells(xlVisible).Cells.Count
'iCountOfRows = .Columns(1).Rows.SpecialCells(xlVisible).Count
MsgBox "Количество отфильтрованных строк " & iCountOfRows - 1
End With
End If
End With |
Примечание : Строки, которые являются частью заголовка таблицы, иначе
называемой шапкой, не участвуют в подсчёте.
Ответ :
With ThisWorkbook.Worksheets(1)
If .AutoFilterMode = True Then
For Each iCell In .AutoFilter.Range.Columns(1).Cells '.Rows
MsgBox iCell.Value
Next
End If
End With |
Комментарий : Данный способ позволяет перебрать в цикле
все ячейки первого столбца в котором установлен фильтр, поэтому ячейки,
которые являются частью заголовка таблицы, также участвуют в цикле. Однако, как
правило, необходимо перебрать только те ячейки, которые были получены вследствии
применения автофильтра и без учёта заголовка таблицы.
Именно такой способ опубликован в следующем совете.
Ответ :
With ThisWorkbook.Worksheets(1)
If .AutoFilterMode = True And .FilterMode = True Then
With .AutoFilter.Range.Columns(1)
Set iFilterRange = _
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
For Each iCell In iFilterRange
MsgBox iCell.Value
Next
End With
.ShowAllData 'Отобразить всё - необязательно
End If
End With |
Примечание : Обратите внимание на свойство Columns,
используя его Вы сможете осуществить цикл в нужном столбце диапазона в
котором установлен и активирован автофильтр.
Ответ :
Для того, чтобы получить перечень уникальных, т.е. неповторяющихся
значений столбца(или нескольких столбцов) можно использовать расширенный
фильтр. Если это разовая акция или использование макросов нежелательно, то
здесь [FAQ] можно найти
подробное описание процесса, без применения VBA.
Если же нужно проделать всё тоже самое, но программно, то достаточно
просто записать свои действия макрорекордером
[FAQ1], проанализировать
полученный код, избавиться от мусора, например, от ненужного выделения листа и
диапазона и получить готовый макрос.
А если макрорекордеру Вы предпочитаете чтение данного сайта, то так
можно отфильтровать данные столбца [A:A] активного рабочего листа и получить
список уникальных данных.
Range("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
| |
Обратите внимание на то, что в этом примере, повторы никуда не исчезают,
они именно скрываются. Если это неприемлемо, то результат фильтрации можно
скопировать в другие ячейки. При этом можно указывать ячейки другого рабочего
листа, в т.ч. и нового.
| Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Worksheets.Add.Range("A1"), Unique:=True | |
|
Worksheets("Лист1").Range("A1:С1000").AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=Worksheets("Лист2").Range("A1"), Unique:=True
|
Важно :
Расширенный фильтр всегда воспринимает первую ячейку
указанного диапазона как заголовок таблицы(шапку) и если таблица не имеет
шапки, а значение первой ячейки будет повторяться и далее, то после фильтрации
Вы получите один повтор. Этой неприятности можно избежать, если проверять
наличие заголовка(шапки)
[FAQ618] и в случае её
отсутствия (перед фильтрацией) просто создавать её (возможно даже программно)
При выборе фильтрации на месте, необходимо учитывать, что
в этом случае расширенный фильтр будет обрабатывать не значения ячеек, а
формулы. Проще говоря, если в столбце будут константы, Вы можете не
обращать внимание на это предупреждение, но если в столбце будут формулы,
то в результате фильтрации Вы можете получить повторы, т.к. для расширенного
фильтра две следующие формулы(ссылки) =B2 и =B3 уникальны, хотя они могут
возвращать одно и тоже значение. Бороться с этим можно, если копировать
результат в другое место (допускается копирование в ячейки скрытого листа)
Ответ :
Вопрос выбран посетителями
Dim iDateOne As Date
Dim iDateTwo As Date
iDateOne = "08.09.2004"
iDateTwo = "08.10.2004"
iCriteria1 = ">=" & Format(iDateOne, "#")
iCriteria2 = "<=" & Format(iDateTwo, "#")
Range("A1").AutoFilter Field:=1, Criteria1:=iCriteria1, Operator:=xlAnd, Criteria2:=iCriteria2
|
 |
Совет : Вместо Format(iDate, "#") можно использовать
Format(iDate, "General Number")
|
|
|
Вариант II.
| iDateOne = #9/8/2004# ' "08.09.04"
iDateTwo = #10/8/2004# ' "08.10.04"
iCriteria1 = ">=" & CDbl(iDateOne)
iCriteria2 = "<=" & CDbl(iDateTwo)
Range("A1").AutoFilter Field:=1, Criteria1:=iCriteria1, Operator:=xlAnd, Criteria2:=iCriteria2
| |
Вариант III.
| iDateOne = #9/8/2004# ' "08.09.04"
iDateTwo = #10/8/2004# ' "08.10.04"
With Application
iCriteria1 = ">=" & .Text(iDateOne, "@")
iCriteria2 = "<=" & .Text(iDateTwo, "@")
End With
Range("A1").AutoFilter Field:=1, Criteria1:=iCriteria1, Operator:=xlAnd, Criteria2:=iCriteria2
|
Внимание : Критерии взяты только в качестве примера !
Ответ :
Актуально для MS Excel 97, 2000, XP
Для того, чтобы отфильтровать столбец (содержащий даты),
достаточно воспользоваться предыдущим советом [FAQ35],
но если даты, которые служат критерием отбора, находятся в ячейках,
то можно поступить и проще :
iCriteria1 = ">=" & Range("B1").Value2
iCriteria2 = "<=" & Range("C1").Value2
Range("A:A").AutoFilter Field:=1, Criteria1:=iCriteria1, Operator:=xlAnd, Criteria2:=iCriteria2
| |
|
Columns(1).AutoFilter Field:=1, Operator:=xlAnd, _
Criteria1:=">=" & Cells(1, 2).Value2, Criteria2:="<=" & Cells(1, 3).Value2 | |
|
[A1:A1000].AutoFilter 1, ">=" & [B1].Value2, xlAnd, "<=" & [C1].Value2 |
Предполагается, что в результате фильтрации нам необходимо получить
список, содержащий даты, которые больше или равны дате из ячейки "B1" и
меньше или равны, чем дата в ячейке "C1"
Ответ :
Для того, чтобы автоматически, т.е. сразу после применения автофильтра,
изменить цвет заливки в заголовках отфильтрованного столбца, проделайте следующее :
1. Откройте нужную рабочую книгу
2. Перейдите в редактор VBA (ALT + F11) и скопируйте любую из представленных
авторских функций в любой стандартный модуль. В случае отсутствия модуля,
его нужно создать. Затем выйдите из редактора (ALT + Q)
3. Выделите все ячейки, которые являются частью заголовка таблицы,
иначе называемой шапкой.
4. В меню Формат выберите команду Условное форматирование.
В стандартном диалоговом окне : в поле со списком выберите Формула
и введите либо =IsFilter()
(если Вы выбрали первый или второй вариант) либо
=IsFilter(B2)
(если Вы выбрали третий вариант, где B2 ссылка на самую первую ячейку
выделенного диапазона) После чего, кликните кнопку Формат, установите
нужные параметры форматирования (при этом, Вы можете изменить не только цвет
заливки, но и, например, цвет шрифта, а также его начертание),
а затем кликните кнопку OK.
5. Сохраните все внесённые изменения (CTRL + S)
Private Function IsFilter() As Boolean
'***************************************************'
' Автор Климов Павел Юрьевич '
' http://www.msoffice.nm.ru '
'***************************************************'
Dim iCell As Range
Set iCell = Application.Caller
With iCell.Worksheet
If .AutoFilterMode = True Then
With .AutoFilter
For iColumn% = 1 To .Filters.Count
If Not Intersect(iCell, .Range. _
Columns(iColumn%)) Is Nothing Then
IsFilter = .Filters(iColumn%).On '
Exit Function
End If
Next
End With
End If
End With
End Function | |
| Private Function IsFilter() As Boolean
'***************************************************'
' Автор Климов Павел Юрьевич '
' http://www.msoffice-nm.ru '
'***************************************************'
Private Function IsFilter() As Boolean
Dim iCell As Range, iRow As Range
Set iCell = Application.Caller
With iCell.Worksheet
If Not .AutoFilterMode Then Exit Function
With .AutoFilter
iColumn% = .Range.Column - 1
Set iRow = Intersect(iCell.EntireColumn, .Range.EntireRow)
If Not Intersect(iCell, iRow) Is Nothing Then _
IsFilter = .Filters(iRow.Column - iColumn%).On
End With
End With
End Function | |
| Private Function IsFilter(iCell As Range) As Boolean
'***************************************************'
' Автор Климов Павел Юрьевич '
' http://www.msoffice.nm.ru '
'***************************************************'
With iCell.Parent
If .AutoFilterMode = True Then
Dim iCellFilter As Range
For Each iCellFilter In .AutoFilter.Range.Rows(1).Cells
iColumn% = iColumn% + 1
If iCellFilter.Address = iCell.Address Then
IsFilter = .AutoFilter.Filters(iColumn%).On
Exit Function
End If
Next
End If
End With
End Function |
Ответ :
Для того, чтобы автоматически, т.е. сразу после применения автофильтра,
вывести в нужных ячейках критерии фильтрации, проделайте следующее :
1. Откройте нужную рабочую книгу
2. Перейдите в редактор VBA (ALT + F11) и скопируйте нижеприведённую
авторскую функцию в любой стандартный модуль. В случае отсутствия модуля,
его нужно создать. После чего, выйдите из редактора (ALT + Q)
3. Выделите ячейки, в которых, по Вашему мнению, должны отображаться
критерии отбора(фильтрации) Причём, эти ячейки должны быть расположены в
одной строке, строго над (или под, что менее удобно) необходимой таблицей.
4. Затем введите =GetCriteria()
и нажмите клавиши CTRL + ENTER
5. Сохраните все внесённые изменения (CTRL + S)
Private Function GetCriteria$()
'***************************************************'
' Автор Климов Павел Юрьевич '
' http://www.msoffice.nm.ru '
'***************************************************'
Application.Volatile True
Dim iCell As Range, iFilterColumn As Range
Set iCell = Application.Caller
With iCell.Worksheet
If Not .AutoFilterMode Or Not .FilterMode Then
'Здесь можно вывести отчёт о состоянии автофильтра
Exit Function
End If
For Each iFilterColumn In .AutoFilter.Range.Columns
iColumn% = iColumn% + 1
If Not Intersect(iFilterColumn, _
iCell.EntireColumn) Is Nothing Then
With .AutoFilter.Filters(iColumn%) '
If Not .On Then Exit Function '
GetCriteria$ = .Criteria1
If .Operator = xlAnd Then
GetCriteria$ = GetCriteria$ & " И " & .Criteria2
ElseIf .Operator = xlOr Then
GetCriteria$ = GetCriteria$ & " ИЛИ " & .Criteria2
End If
Exit Function
End With
End If
Next
End With
End Function |
Ответ :
Если необходимо, чтобы критерии отбора вводились в ячейки
соответствующего столбца, а сама фильтрация осуществлялась сразу после
установки "флажка" , который находится в заголовке(шапке) этого столбца,
то :
1. Откройте нужную рабочую книгу
2. Выделите рабочий лист, в котором необходимо фильтровать список.
3. Выберите пустую строку, которая в дальнейшем будет служить местом
хранения критериев, в данном примере, это самая первая строка. Обратите
внимание на то, что ячейки должны быть расположены строго над
(или под, что менее удобно) необходимой таблицей. Проще говоря, в ячейке
A1 находится условие фильтрации столбца [A:A], в ячейке B1 условие отбора
для столбца [B:B] и т.д.
4. Затем, создайте для каждого столбца свой Флажок, для этого
воспользуйтесь родным элементом управления с панели "Формы" и расположите
их в заголовке столбца.
5. Проследите, чтобы каждому "флажку" был назначен макрос
CheckBox_Filter()
Совет : Можно создать один единственный элемент управления,
назначить ему макрос, а затем просто копировать его.
6. Перейдите в модуль нужного листа, для этого подведите курсор мышки
к ярлычку выделенного листа, нажмите на правую кнопку мышки, и в появившемся
контекстном меню выберите пункт Исходный текст.
7. Скопируйте нижеприведённый макрос в модуль листа.
После чего, выйдите из редактора (ALT + Q)
8. Присвойте диапазону, который Вы планируете фильтровать, имя База_данных
[FAQ]
[FAQ22]
(этот пункт можно пропустить и в макросе вместо "DataBase" просто указать
адрес диапазона, например, "A3:E100")
9. Сохраните все внесённые изменения (CTRL + S)
Private Sub CheckBox_Filter()
If Not Me.ProtectContents Then
With Me.CheckBoxes(Application.Caller)
With .TopLeftCell
iField& = .Column
iCriteria$ = .EntireColumn.Cells(1).Text
End With
If .Value = xlOff Then
Me.Range("DataBase").AutoFilter Field:=iField&
Else
Me.Range("DataBase").AutoFilter _
Field:=iField&, Criteria1:=iCriteria$
End If
End With
Else
MsgBox "Рабочий лист защищён", vbExclamation, ""
End If
End Sub |
Комментарий :
Если необходимо отфильтровать данные на защищённом рабочем листе,
то можно воспользоваться следующим советом
[FAQ86]
Если ячейка, которая предназначена для хранения критериев
отбора, пуста, то можно не фильтровать этот столбец, т.е.
при установке "флажка" просто отказаться от действий, не имеющих особого
смысла (за исключением случаев, когда в результате фильтрации необходимо
получить именно пустые ячейки)
Если отфильтрованный столбец необходимо как-то "выделить", то
пример с изменением цвета заливки ячейки с критерием, можно найти в этом
примере.
Ответ :
Если Вы планируете фильтровать таблицу только программно и
не хотите, чтобы критерии отбора были случайно (или умышленно) изменены
с помощью выпадающего списка, то эти кнопки со стрелочками можно
просто скрыть, т.е. воспользоваться одним из двух нижеприведённых
вариантов, естественно, учитывая особенности каждого.
Вариант I.
Актуально для MS Excel 95-2003
Private Sub HiddenAllDropDowns()
Dim iShape As Shape
For Each iShape In Worksheets(1).Shapes
If iShape.Type = msoFormControl Then
If iShape.FormControlType = _
xlDropDown Then iShape.Visible = msoFalse
End If
Next
End Sub | |
| Private Sub HiddenAllDropDowns2()
Dim iShape As Shape
For Each iShape In Worksheets(1).Shapes
If TypeName(iShape.DrawingObject) = "DropDown" Then
iShape.Visible = msoFalse
End If
Next
End Sub |
Комментарий :
Не рекомендуется применение данного макроса, когда в рабочем листе,
кроме фильтра, присутствуют также элементы управления Поле со списком
с панели инструментов "Формы", и сводные таблицы содержащие выпадающие
списки, т.к. он скроет все вышеперечисленное.
Если в листе вообще нет других графических об'ектов, даже примечаний
(комментариев), то все имеющиеся проверки можно убрать.
Этот макрос можно использовать даже в тех случаях, когда
указанный рабочий лист защищён, в т.ч. и в отношении об'ектов.
Ещё раз обратите внимание на то, что он работает только
в версиях с Excel95 по Excel2003 включительно.
Вариант II.
Private Sub AutoFilterHiddenDropDowns()
Dim iAutoFilter As AutoFilter, iFilter As Filter, iDiapazon As Range
If Лист1.AutoFilterMode = True Then
Set iAutoFilter = Лист1.AutoFilter
Set iDiapazon = iAutoFilter.Range
For Each iFilter In iAutoFilter.Filters
iColumn% = iColumn% + 1
With iFilter
If .On = True Then
If .Operator = xlAnd Or .Operator = xlOr Then
iDiapazon.AutoFilter _
iColumn%, .Criteria1, .Operator, .Criteria2, False
Else
iDiapazon.AutoFilter iColumn%, .Criteria1, , , False
End If
Else
iDiapazon.AutoFilter iColumn%, , , , False
End If
End With
Next
End If
End Sub | |
| Private Sub AutoFilterHiddenDropDowns2()
Dim iDiapazon As Range, iFilters As Filters
Dim iAutoFilter As AutoFilter, iColumn%
Set iAutoFilter = Лист1.AutoFilter
If Not iAutoFilter Is Nothing Then
Set iFilters = iAutoFilter.Filters
Set iDiapazon = iAutoFilter.Range
For iColumn = 1 To iFilters.Count
With iFilters(iColumn)
If .On = True Then
If .Operator = xlAnd Or .Operator = xlOr Then
iDiapazon.AutoFilter Field:=iColumn, _
Criteria1:=.Criteria1, Operator:=.Operator, _
Criteria2:=.Criteria2, VisibleDropDown:=False
Else
iDiapazon.AutoFilter Field:=iColumn, _
Criteria1:=.Criteria1, VisibleDropDown:=False
End If
Else
iDiapazon.AutoFilter Field:=iColumn, VisibleDropDown:=False
End If
End With
Next
End If
End Sub |
Комментарий :
Если рабочий лист защищён, то Вы получите ошибку, которую можно
избежать, если воспользоваться следующим советом
[FAQ86]
Если фильтр уже применён/активирован, причём об'ём отфильтрованных данных
довольно велик, то на время повторной фильтрации, имеет смысл заблокировать
обновление экрана [FAQ43]
Ответ :
Актуально для MS Excel 2003 (и старше)
Если необходимо избавиться от автофильтра (т.е. отобразить все строки
и убрать выпадающие списки (кнопки со стрелками)) из рабочего листа и "умных"
таблиц (списков), то можно использовать следующий вариант, где необходимо
просто указать свой рабочий лист.
Private Sub ShowAutoFilterFalse()
Лист1.AutoFilterMode = False
Dim iListObject As ListObject
For Each iListObject In Лист1.ListObjects
iListObject.ShowAutoFilter = False
Next
End Sub | |
| Private Sub ShowAutoFilterFalse2()
With Worksheets(1) 'Worksheets("Отчёт")
.AutoFilterMode = False
Dim iListObject As ListObject
For Each iListObject In .ListObjects
iListObject.ShowAutoFilter = False
Next
End With
End Sub |
Ответ :
Актуально для MS Excel 95-2003
Если возникнет необходимость в сохранении критериев фильтрации
автофильтра и их программном восстановлении (только в течении
работы с книгой), то для сохранения, можно использовать макрос
AutoFilterSave, а для того, чтобы вернуть всё на круги
своя AutoFilterApply или AutoFilterApply2
Private iList As Worksheet
Private iAddress$, iColumn%, iArr() As Variant
Private Sub AutoFilterSave()
Set iList = ActiveSheet 'Можно указать вполне конкретный лист
If iList.AutoFilter Is Nothing Then
MsgBox "Aвтофильтр отсутствует", vbCritical, iList.Name
Exit Sub
End If
With iList.AutoFilter.Filters
ReDim iArr(1 To .Count, 1 To 3)
For iColumn = 1 To .Count
With .Item(iColumn)
If .On = True Then
iArr(iColumn, 1) = .Criteria1
If .Operator = xlOr Then
iArr(iColumn, 2) = .Operator
iArr(iColumn, 3) = .Criteria2
End If
End If
End With
Next
iAddress = .Parent.Range.Address
End With
End Sub
Private Sub AutoFilterApply()
If iAddress = "" Then
MsgBox "Восстановление невозможно ...", vbCritical, ""
Exit Sub
End If
Dim iSource As Range: Set iSource = iList.Range(iAddress)
For iColumn = 1 To UBound(iArr)
If Not IsEmpty(iArr(iColumn, 1)) Then
If iArr(iColumn, 2) = xlOr Then
iSource.AutoFilter iColumn, _
iArr(iColumn, 1), iArr(iColumn, 2), iArr(iColumn, 3)
Else
iSource.AutoFilter iColumn, iArr(iColumn, 1)
End If
Else
iSource.AutoFilter iColumn
End If
Next
End Sub
Private Sub AutoFilterApply2()
If iAddress = "" Then
MsgBox "Восстановление невозможно ...", vbCritical, ""
Exit Sub
End If
If iList.FilterMode = True Then iList.ShowAllData 'iList.FilterMode = False
With iList.Range(iAddress)
For iColumn = 1 To UBound(iArr)
If Not IsEmpty(iArr(iColumn, 1)) Then
If iArr(iColumn, 2) = xlOr Then
.AutoFilter iColumn, _
iArr(iColumn, 1), iArr(iColumn, 2), iArr(iColumn, 3)
Else
.AutoFilter iColumn, iArr(iColumn, 1)
End If
End If
Next
End With
End Sub |
Ответ :
Актуально для MS Excel 2007 (и старше)
Если возникнет необходимость, с помощью автофильтра, получить
все даты определённого месяца, но без учёта года, то начиная с XL2007
это можно осуществить так :
Private Sub AutoFilter_ChangeMonth()
Dim iMonth%: iMonth = 2 'Укажите свой месяц
Range("A:A").AutoFilter Field:=1, Criteria1:=iMonth + 20, Operator:=xlFilterDynamic
End Sub |
Совет : Если Вы являетесь обладателем MS Excel 2003 (или младше),
то решить поставленную задачу сможете, либо с помощью автофильтра +
доп. столбец с формулами, которые будут возвращать месяц, либо с помощью
расширенного фильтра, только в этом случае, Вам также придётся
использовать дополнительные ячейки (2-е шт.)
Ответ :
Актуально для MS Excel 2007 (и старше)
На самом деле, даже в 2007 критериев всего два, но в этой
версии критерием отбора может быть массив. Поэтому, если мы захотим,
с помощью автофильтра, получить ячейки, содержащие, допустим, следующие
фамилии "Иванов", "Петров", "Сидоров", то это можно будет осуществить, так :
Range("A:A").AutoFilter Field:=1, _
Criteria1:=Array("Иванов", "Петров", "Сидоров"), Operator:=xlFilterValues
| |
|
[A:A].AutoFilter 1, Array("Иванов", "Петров", "Сидоров"), xlFilterValues
| |
Если критерии должны располагаться в ячейках рабочего листа, то имейте ввиду,
что диапазон-источник должен содержать одну строку(или * столбец). Если
же Вы нарушите это правило, то результат будет отличаться от желаемого, т.к.
при указании диапазона A1:B3 только значения ячеек A1 и B1
будут использованы в качестве критерия отбора. * По этой же причине, данные,
которые находятся в столбце, например, A1:A3, необходимо ещё и
транспонировать (см. нижеопубликованный код)
| Лист1.Range("A:A").AutoFilter Field:=1, _
Criteria1:=Лист2.Range("A1:C1").Value, Operator:=xlFilterValues
| |
|
Лист1.Range("A:A").AutoFilter Field:=1, Criteria1:= _
Application.Transpose(Лист2.Range("A1:A3")), Operator:=xlFilterValues
|
Совет : Если Вы являетесь обладателем MS Excel 2003 (или младше),
то решить поставленную задачу сможете с помощью расширенного фильтра,
только для этого обязательно придётся использовать дополнительные ячейки.
Ответ :
Актуально для MS Excel 2007 (и старше)
Не секрет, что если критерием отбора является массив, то
использовать символы подстановки ? * и получить желаемый результат,
не получится. Однако, это ограничение можно "обойти", если сначала
найти все частичные совпадения, например, с помощью стандартного
поиска, а затем, просто использовать найденные значения.
Private Sub AutoFilter_LikeText()
Dim iAddress$, iText$, iCriteria1(), iCriteria2()
Dim iSource As Range, iCell As Range, iCount1&, iCount2&
Set iSource = Range("A:A") '[A:A]
iCriteria1 = Array("Иванов", "Петров", "Сидоров")
For iCount1 = 0 To UBound(iCriteria1)
iText = iCriteria1(iCount1)
Set iCell = iSource.Find(iText, , xlValues, xlPart)
'Set iCell = iSource.Find("*" & iText & "*", , xlValues, xlWhole)
If Not iCell Is Nothing Then
iAddress = iCell.Address
Do
ReDim Preserve iCriteria2(iCount2)
iCriteria2(iCount2) = iCell.Value
iCount2 = iCount2 + 1
Set iCell = iSource.FindNext(iCell)
Loop While iAddress <> iCell.Address
End If
Next
If iCount2 > 0 Then
iSource.AutoFilter 1, iCriteria2, xlFilterValues
Else
MsgBox Join(iCriteria1, vbCrLf), , "Ничего не найдено"
End If
End Sub |
Важно : Обратите внимание на то, что при поиске можно
использовать символы подстановки ? * , что даёт нам возможность задать
разные условия отбора(фильтрации)
Например, получить все ячейки, где текст :
1) начинается с "Иванов" (Иванов, Иванова)
2) заканчивается на "ин" (Лукин, Букин)
3) только второй символ может быть любым (Рязанов, Рузанов)
|
iCriteria1 = Array("Иванов*", "*ин", "Р?занов")
Set iCell = iSource.Find(iText, , xlValues, xlWhole) | |
Так же можно использовать словарь для создания массива всех
подходящих под критерии отбора, данных. Обратите внимание на
то, что первая ячейка в столбца должна содержать заголовок
(шапку)
| Option Compare Text
Private Sub AutoFilter_LikeText2()
Dim iCriteria As Object, iSource As Range
Dim iArr1, iArr2, iText, iCount1&, iCount2&, iCount&
Set iCriteria = CreateObject("Scripting.Dictionary")
Set iSource = Range("A1", Cells(Rows.Count, "A").End(xlUp))
iArr2 = Array("Иванов*", "*Водкин*", "Сидоров?")
iArr1 = iSource.Value: iCount = UBound(iArr2)
For iCount1 = 2 To UBound(iArr1)
iText = iArr1(iCount1, 1)
For iCount2 = 0 To iCount
If iText Like iArr2(iCount2) Then
iCriteria(iText) = iText: Exit For
End If
Next
Next
If iCriteria.Count > 0 Then
iSource.AutoFilter 1, iCriteria.Items, xlFilterValues
Else
MsgBox "В столбце нет данных, подходящих под критерии отбора"
End If
End Sub | |
| Option Compare Text
Private Sub AutoFilter_LikeText3()
Dim iCriteries As Object, iSource As Range
Dim iArr, iText, iCriteria1, iCriteria
iCriteria1 = Array("Иванов*", "*Водкин*", "Сидоров?")
Set iCriteries = CreateObject("Scripting.Dictionary")
Set iSource = Range("A1", Cells(Rows.Count, "A").End(xlUp))
For Each iText In iSource.Value
For Each iCriteria In iCriteria1
If iText Like iCriteria Then
iCriteries(iText) = iText: Exit For
End If
Next
Next
If iCriteries.Count > 0 Then
iSource.AutoFilter 1, iCriteries.Items, xlFilterValues
Else
MsgBox "В столбце нет данных, подходящих под критерии отбора"
End If
End Sub |
Важно : Во всех двух способах, т.е. и при поиске и при
определении последней видимой заполненной ячейки, нужно иметь
ввиду, что макрос не должен выполняться при наличии скрытых
строк.
Совет : Если Вы являетесь обладателем MS Excel 2003 (или младше),
то решить поставленную задачу сможете с помощью расширенного фильтра,
только для этого обязательно придётся использовать дополнительные ячейки.
Ответ :
Актуально для MS Excel 2007 (и старше)
Если Вы являетесь обладателем новых версий Excel, то для того,
чтобы после выбора вручную всех необходимых критериев отбора и
фильтрации столбца - можно было для каждого критерия - создать новый
рабочий лист и скопировать туда полученные данные, просто выполните
нижеопубликованный макрос.
Обратите внимание на то, что в данном FAQ речь идёт только
о таком типе фильтре
 (см. скрин)
Private Sub ItemsFilterToList()
Dim iList1 As Worksheet, iList2 As Worksheet, iColumn&, iArr, Item
Dim iAutoFilter As AutoFilter, iFilter As Filter, iSource As Range
Set iList1 = ActiveSheet: Set iAutoFilter = iList1.AutoFilter
If iAutoFilter Is Nothing Then Exit Sub
For Each iFilter In iAutoFilter.Filters
iColumn = iColumn + 1
If iFilter.On = True Then
If iFilter.Operator = xlFilterValues Then
Set iSource = iAutoFilter.Range
iArr = iFilter.Criteria1: Exit For
End If
End If
Next
If IsArray(iArr) = True Then
On Error Resume Next
Application.ScreenUpdating = False
For Each Item In iArr
Set iList2 = Worksheets.Add
iList2.Name = Mid(Item, 2, 31)
iSource.AutoFilter iColumn, Item
iSource.Copy iList2.Cells(1)
Next
iList1.ShowAllData 'Данные-Сортировка и фильтр-Очистить
'iSource.AutoFilter iColumn, iArr, xlFilterValues
Application.ScreenUpdating = True
End If
End Sub |
Важно : Для предотвращения ошибки, которая возникнет, если в
активной книге уже будет наличествовать лист с именем, совпадающим с
любым из выбранных критериев отбора(фильтрации), либо создавайте листы
в новой книге, либо предварительно проверяйте их наличие.
Ответ :
Если необходимо отфильтровать строки так, чтобы видимыми
остались только те строки, где в любом столбце таблицы будут
находиться данные, подходящие под критерий отбора, то можно
использовать
дополнительный столбец с формулой. И фильтровать именно этот
столбец, но если создание дополнительного столбца нежелательно,
то можно применить нижеопубликованный макрос. Разумеется,
непосредственно фильтрации там нет, но тем не менее, результат
получится ~ аналогичным применению фильтра, поэтому FAQ размещён
именно в этом разделе.
Private Sub FilterToAllColumns()
Dim iSource As Range, iRow As Range, iCriteria$: iCriteria = ">3"
With ActiveSheet.UsedRange
If .Rows.Count = 1 Then MsgBox _
"Таблица не содержит строк", vbCritical, "": Exit Sub
Set iSource = .Resize(.Rows.Count - 1).Offset(1)
End With
Application.ScreenUpdating = False
iSource.Rows.Hidden = True
For Each iRow In iSource.Rows
If Application.CountIf(iRow, iCriteria) > 0 Then
iRow.Hidden = False
End If
Next
Application.ScreenUpdating = True
End Sub | |
Если же "фильтровать" нужно не по всем столбцам, а только по
конкретным, например, по столбцам "F:P", то при условии, что
таблица начинается с самого первого столбца, т.е. c "A" :
| Private Sub FilterToChangeColumns()
Dim iSource As Range, iRow As Range, iCriteria$: iCriteria = "Иванов*"
With ActiveSheet.UsedRange.Columns("F").Resize(, 11)
If .Rows.Count = 1 Then MsgBox _
"Таблица не содержит строк", vbCritical, "": Exit Sub
Set iSource = .Resize(.Rows.Count - 1).Offset(1)
End With
Application.ScreenUpdating = False
iSource.Rows.Hidden = True
For Each iRow In iSource.Rows
If Application.CountIf(iRow, iCriteria) > 0 Then
iRow.Hidden = False
End If
Next
Application.ScreenUpdating = True
End Sub | |
Обратите внимание на то, что если указать столбцы неправильно,
например, если таблица будет насчитывать всего пять столбцов и,
соответственно, она закончится на столбце "E", то будут скрыты
все строки. И если это недопустимо и/или Вы хотите указывать
столбцы в более привычной манере, то :
| Private Sub FilterToChangeColumns()
Dim iList As Worksheet, iCriteria$: iCriteria = "Иванов*"
Dim iSource As Range, iRow As Range
Set iList = Worksheets(1) 'Worksheets("Таблица")
Set iSource = Intersect(iList.UsedRange, iList.Range("F:P"))
If iSource Is Nothing Then MsgBox _
"В этих столбцах нет данных", vbCritical, "": Exit Sub
With iSource
If .Rows.Count = 1 Then MsgBox _
"Таблица не содержит строк", vbCritical, "": Exit Sub
Set iSource = .Resize(.Rows.Count - 1).Offset(1)
End With
Application.ScreenUpdating = False
iSource.Rows.Hidden = True
For Each iRow In iSource.Rows
If Application.CountIf(iRow, iCriteria) > 0 Then iRow.Hidden = False
Next
Application.ScreenUpdating = True
End Sub |
Важно : Обратите внимание на то, что при здесь также возможно
использовать символы подстановки ? * , что даёт нам возможность задать
разные условия отбора(фильтрации)
| | | |
| | | | | | | | |
|
|
| | | |
|
|
|
Вопросы - Синонимы
Воспроизведение любых опубликованных здесь материалов возможно только с
письменного разрешения автора :