Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Универсальный макрос для быстрого переключения между значениями фильтра за счет "горячих" клавиш
 
#1
19.04.2018 19:05:29
Помогите с написанием макроса, который легко можно будет копировать в любые файлы и, который будет помогать осуществлять быстрое переключение по порядку между значениями фильтра.
Желательно, чтобы макрос был крайне простым для легкого его внедрения в другие файлы.
Улыбнись.
 
 
 
#2
19.04.2018 19:38:52
Цитата
falmrom написал: Желательно...
Так Вам ПОМОЧЬ или написать ЗА ВАС?
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
19.04.2018 20:05:23
Цитата
Sanja написал:
Так Вам ПОМОЧЬ или написать ЗА ВАС?
Помочь.
Вот файл с примером макроса, но я не могу его унифицировать, т.к. не знаю VBA.
Улыбнись.
 
 
 
#4
21.04.2018 06:05:04
Работает по столбцу с активной ячейкой:
Код
Sub SetAutoFilter()
Dim aa As Range, DC As Object, a&, b%, dt$, qq
Set DC = CreateObject("Scripting.Dictionary")
Set aa = ActiveCell.CurrentRegion
b = ActiveCell.Column
qq = Intersect(aa, ActiveCell.EntireColumn).Value
For a = 2 To aa.Rows.Count
  If Not DC.exists(CStr(qq(a, 1))) Then DC.Add CStr(qq(a, 1)), a
Next
If ActiveSheet.AutoFilterMode Then
  With ActiveSheet
    .AutoFilter.Range.Cells(1, b).Select
    If .AutoFilterMode Then
      If .AutoFilter.Filters(b).On Then
        dt = Replace(.AutoFilter.Filters(b).Criteria1, "=", "")
      End If
      If dt <> vbNullString Then
        aa.AutoFilter field:=b
        If qq(DC.Item(dt), 1) = UBound(qq) Then
          aa.AutoFilter field:=b, Criteria1:="=" & qq(2, 1), Operator:=xlFilterValues
        Else: aa.AutoFilter field:=b, Criteria1:="=" & qq(DC.Item(dt) + 1, 1), Operator:=xlFilterValues
        End If
      Else: aa.AutoFilter field:=b, Criteria1:="=" & qq(2, 1), Operator:=xlFilterValues
      End If
    End If
  End With
End If
End Sub
 
 
 
#5
04.05.2018 11:40:58
Anchoret, что-нибудь требуется редактировать в макросе для его работы?  
Улыбнись.
 
 
 
#6
04.05.2018 14:42:28
falmrom, если по вашему примеру + комментарии перед самим макросом, то нет. Можно добавить отключение обновление экрана в начале, и включение в конце.
 
 
 
#7
04.05.2018 16:00:13
Anchoret,макрос работает "вправо", а мне необходимо "вниз")))
Как это дело переделать?)
Улыбнись.
 
 
 
#8
04.05.2018 16:06:32
falmrom, .... В какое право?
 
 
 
#9
04.05.2018 16:44:33
Anchoret,  меня макрос работает по строке, а не по столбцу.
Улыбнись.
 
 
 
#10
04.05.2018 19:49:06
falmrom, макрос работает по столбцу с активной ячейкой. Была ошибка, а точнее не учтены вероятные пустые значения. Поэтому фильтр после встреченных пустых сразу возвращался в начало.
Вот обновленная версия (кнопки переназначены на новые макросы):
Код
Sub PrevFilter()'назад
Application.ScreenUpdating = False
SetAutoFilter -1
Application.ScreenUpdating = True
End Sub
'---------------
Sub NextFilter()'вперед
Application.ScreenUpdating = False
SetAutoFilter 1
Application.ScreenUpdating = True
End Sub
'---------------
Sub SetAutoFilter(ByVal z%)
Dim aa As Range, DC As Object, a&, b%, dt$, arr()
Set DC = CreateObject("Scripting.Dictionary")
Set aa = ActiveCell.CurrentRegion
b = ActiveCell.Column
arr = Intersect(aa, ActiveCell.EntireColumn).Value
For a = 2 To aa.Rows.Count
  If Not DC.exists(CStr(arr(a, 1))) Then DC.Add CStr(arr(a, 1)), DC.Count
Next
If DC.Count < 1 Then Exit Sub
arr = DC.keys()
If ActiveSheet.AutoFilterMode Then
  With ActiveSheet
    .AutoFilter.Range.Cells(1, b).Select
    If .AutoFilterMode Then
      If .AutoFilter.Filters(b).On Then
        dt = Replace(.AutoFilter.Filters(b).Criteria1, "=", "")
      End If
      aa.AutoFilter field:=b
      Select Case z
      Case Is > 0
        If DC.Item(dt) = UBound(arr) Then
          aa.AutoFilter field:=b, Criteria1:="=" & arr(1), Operator:=xlFilterValues
        Else: aa.AutoFilter field:=b, Criteria1:="=" & arr(DC.Item(dt) + 1), Operator:=xlFilterValues
        End If
      Case Else
        If DC.Item(dt) = LBound(arr) Then
          aa.AutoFilter field:=b, Criteria1:="=" & arr(UBound(arr)), Operator:=xlFilterValues
        Else: aa.AutoFilter field:=b, Criteria1:="=" & arr(DC.Item(dt) - 1), Operator:=xlFilterValues
        End If
      End Select
    End If
  End With
End If
End Sub
Изменено: Anchoret - 04.05.2018 19:49:20
 
 
 
#11
18.05.2018 18:23:16
Anchoret, все работает! Большое спасибо!
Улыбнись.
 
 
 
Страницы: 1
Наверх