У Карен из Чикаго есть рабочий лист с 200 столбцами. Выпадающие меню фильтров включены. Ей нужен быстрый способ узнать, к каким столбцам применен фильтр и какой фильтр применен к этим столбцам.
Карен уже знала, что нужно искать значок «Воронка» в строке заголовка, но с сотнями столбцов это могло занять много времени.
Моей первой остановкой был UserVoice. Там была опубликована идея, но за нее был отдан только один голос.
Я спросил своих друзей-MVP, думают ли они, как это сделать.
У Роджера Говье был код, который он изначально написал для статьи о контекстах. Он адаптировал этот код, а затем я адаптировал его код, используя отличный список, представленный на https://yoursumbuddy.com/autofilter-vba-operator-parameters/.
Код Роджера просматривает все столбцы в автофильтре текущего листа. Если фильтр установлен, то он смотрит на ActiveSheet.AutoFilter.Filters.Item(1).Criteria1, .Criteria2и .Operatorвыяснить , что фильтр применяется и то , что был выбран для столбца.
Если вы откроете раскрывающийся список Автофильтр и выберите Энди, Бетти, Чарли, тогда .Criteria1будет массив элементов. Роджер проверяет наличие массива, запрашивая верхнюю границу массива с помощью UBound(.Criteria1). Если есть массив, он перебирает элементы в массиве. Если нет массива, он может просто использовать .Criteria1.
Существует .Criteria2собственность, но это только кажется , будет использоваться , если тип фильтра OR.
.OperatorСвойство имеет ряд числовых кодов:
- 0 для одного предмета
- 1 для И
- 2 для ИЛИ
- 3 из 10 лучших
- 4 для нижних 10
- 5 в 10% лучших
- 6 для нижних 10 процентов
- 7 для фильтрации по значениям
- 8 для цвета ячейки
- 9 для цвета шрифта
- 10 для Icon
- 11 для Dynamic
Если .Operatorравно 11, то в .Criteria1. См. Код VBA ниже, но это 1 для Сегодня, 2 для Вчера, 3 для Завтра и так далее.
Первый код дает Карен список всех фильтров и способов их применения:
Роджер Говье понимал, что этим будет сложно воспользоваться. Он предложил вставить три пустые строки над вашими данными. Запустите ShowFilterValuesкод, и вы можете быстро перейти к следующему отфильтрованному столбцу, используя Ctrl + Shift + RightArrow в строке 1.
Смотреть видео
Скачать файл Excel
Вы можете скачать файл Excel: which-excel-columns-are-filter.xlsm
Или вы можете скопировать и вставить любой макрос снизу.
Sub MessageFilterValues() ' Thanks to Excel MVP Roger Govier for original code ' Modified by Bill Jelen on 12 May 2019 ' based on https://yoursumbuddy.com/autofilter-vba-operator-parameters/ ' This assumes your headings are in row 1. Dim sht As Worksheet Dim f As Long Dim i As Long Dim ItemCount As Long Dim ItemStr As Variant Dim ValA As Variant Dim ValB As Variant Dim ValC As Variant Dim ValD As Variant Set sht = ActiveSheet Msg = "" sht.(A1).Select With sht.AutoFilter currentFiltRange = .Range.Address With .Filters For f = 1 To .Count With .Item(f) If .On Then ValA = "" ValB = "" ValC = "" ValD = "" ' Is .Criteria1 an array? Err.Clear On Error Resume Next ItemCount = UBound(.Criteria1) If Err.Number = 0 Then ItemStr = "" For i = 1 To ItemCount ItemStr = ItemStr & .Criteria1(i) Next i ValA = ItemStr Else ' Not an array ValA = .Criteria1 End If On Error Resume Next ' .Criteria2 is only used for XLOr ValB = .Criteria2 On Error GoTo 0 ' Operator is a series of codes Select Case .Operator Case 0 ValC = "Single Item" Case 1 ValC = "xlAnd" Case 2 ValC = "xlOr" Case 3 ValC = "xlTop10Items" Case 4 ValC = "xlBottom10Items" Case 5 ValC = "xlTop10Percent" Case 6 ValC = "xlBottom10Percent" Case 7 ValC = "xlFilterValues" Case 8 ValC = "xlFilterCellColor" Case 9 ValC = "xlFilterFontColor" Case 10 ValC = "xlFilterIcon" ValA = "Icon #" & .Criteria1.Index Case 11 ValC = "xlFilterDynamic" ' For Dynamic, there are one of 34 values stored in Criteria1 ' Update Criteria1 stored in row 1 Select Case ValA Case 1 ValD = "Today" Case 2 ValD = "Yesterday" Case 3 ValD = "Tomorrow" Case 4 ValD = "This Week" Case 5 ValD = "Last Week" Case 6 ValD = "Next Week" Case 7 ValD = "This Month" Case 8 ValD = "Last Month" Case 9 ValD = "Next Month" Case 10 ValD = "This Quarter" Case 11 ValD = "Last Quarter" Case 12 ValD = "Next Quarter" Case 13 ValD = "This Year" Case 14 ValD = "Last Year" Case 15 ValD = "Next Year" Case 16 ValD = "Year to Date" Case 17 ValD = "Q1" Case 18 ValD = "Q2" Case 19 ValD = "Q3" Case 20 ValD = "Q4" Case 21 ValD = "January" Case 22 ValD = "February" Case 23 ValD = "March" Case 24 ValD = "April" Case 25 ValD = "May" Case 26 ValD = "June" Case 27 ValD = "July" Case 28 ValD = "August" Case 29 ValD = "September" Case 30 ValD = "October" Case 31 ValD = "November" Case 32 ValD = "December" Case 33 ValD = "Above Average" Case 34 ValD = "Below Average" End Select ValA = ValD End Select Msg = Msg & Cells(1, f).Address(0, 0) & ": " & ValA & " " & ValB & " (" & ValC & ")" & vbLf End If End With Next f End With End With If Msg = "" Then Msg = "No columns filtered" MsgBox Prompt:=Msg, Title:="Filtered Columns" End Sub Sub ShowFilterValues() ' Thanks to Excel MVP Roger Govier for original code ' Modified by Bill Jelen on 12 May 2019 ' based on https://yoursumbuddy.com/autofilter-vba-operator-parameters/ ' Requires you to have three blank rows above your data Dim sht As Worksheet Dim filterArray() Dim f As Long Dim i As Long Dim ItemCount As Long Dim ItemStr As Variant Set sht = ActiveSheet sht.Rows("1:3").ClearContents With sht.Rows("1:3") .ClearContents .NumberFormat = "@" With .Font .Bold = True .Color = XlRgbColor.rgbRed End With End With sht.(A4).Select With sht.AutoFilter currentFiltRange = .Range.Address With .Filters ReDim filterArray(1 To .Count) For f = 1 To .Count With .Item(f) If .On Then ' Is .Criteria1 an array? Err.Clear On Error Resume Next ItemCount = UBound(.Criteria1) If Err.Number = 0 Then ItemStr = "" For i = 1 To ItemCount ItemStr = ItemStr & .Criteria1(i) Next i sht.Cells(1, f) = ItemStr Else ' Not an array sht.Cells(1, f) = .Criteria1 End If On Error Resume Next ' .Criteria2 is only used for XLOr sht.Cells(2, f) = .Criteria2 On Error GoTo 0 ' Operator is a series of codes Select Case .Operator Case 0 sht.Cells(3, f) = "Single Item" Case 1 sht.Cells(3, f) = "xlAnd" Case 2 sht.Cells(3, f) = "xlOr" Case 3 sht.Cells(3, f) = "xlTop10Items" Case 4 sht.Cells(3, f) = "xlBottom10Items" Case 5 sht.Cells(3, f) = "xlTop10Percent" Case 6 sht.Cells(3, f) = "xlBottom1010Percent" Case 7 sht.Cells(3, f) = "xlFilterValues" Case 8 sht.Cells(3, f) = "xlFilterCellColor" Case 9 sht.Cells(3, f) = "xlFilterFontColor" Case 10 sht.Cells(3, f) = "xlFilterIcon" sht.Cells(1, f) = "Icon #" & .Criteria1.Index Case 11 sht.Cells(3, f) = "xlFilterDynamic" ' For Dynamic, there are one of 34 values stored in Criteria1 ' Update Criteria1 stored in row 1 Select Case sht.Cells(1, f).Value Case 1 sht.Cells(1, f).Value = "Today" Case 2 sht.Cells(1, f).Value = "Yesterday" Case 3 sht.Cells(1, f).Value = "Tomorrow" Case 4 sht.Cells(1, f).Value = "This Week" Case 5 sht.Cells(1, f).Value = "Last Week" Case 6 sht.Cells(1, f).Value = "Next Week" Case 7 sht.Cells(1, f).Value = "This Month" Case 8 sht.Cells(1, f).Value = "Last Month" Case 9 sht.Cells(1, f).Value = "Next Month" Case 10 sht.Cells(1, f).Value = "This Quarter" Case 11 sht.Cells(1, f).Value = "Last Quarter" Case 12 sht.Cells(1, f).Value = "Next Quarter" Case 13 sht.Cells(1, f).Value = "This Year" Case 14 sht.Cells(1, f).Value = "Last Year" Case 15 sht.Cells(1, f).Value = "Next Year" Case 16 sht.Cells(1, f).Value = "Year to Date" Case 17 sht.Cells(1, f).Value = "Q1" Case 18 sht.Cells(1, f).Value = "Q2" Case 19 sht.Cells(1, f).Value = "Q3" Case 20 sht.Cells(1, f).Value = "Q4" Case 21 sht.Cells(1, f).Value = "January" Case 22 sht.Cells(1, f).Value = "February" Case 23 sht.Cells(1, f).Value = "March" Case 24 sht.Cells(1, f).Value = "April" Case 25 sht.Cells(1, f).Value = "May" Case 26 sht.Cells(1, f).Value = "June" Case 27 sht.Cells(1, f).Value = "July" Case 28 sht.Cells(1, f).Value = "August" Case 29 sht.Cells(1, f).Value = "September" Case 30 sht.Cells(1, f).Value = "October" Case 31 sht.Cells(1, f).Value = "November" Case 32 sht.Cells(1, f).Value = "December" Case 33 sht.Cells(1, f).Value = "Above Average" Case 34 sht.Cells(1, f).Value = "Below Average" End Select End Select End If End With Next f End With End With End SubMVP Excel Джон Акампора предлагает надстройку Filter-Mate за 27 долларов с аналогичной функциональностью. Узнайте больше на https://www.excelcampus.com/filter-mate/.
