Excel фильтр инвертировать выделение

I’ve written a bit of VBA that extends Excel and provides this functionality. It adds a new context menu (right-click menu) option off the Filter sub-menu (see screenshot).

You need to call the AddToCellMenu subroutine to make the menu item appear. If you want to make that permament for all your Excel sessions, you’ll need to put this code in a personal workbook or add-in you have running and then call AddToCellMenu on the Workbook_Open event, or something similar.

Anyway here’s the code:

Option Explicit

Public Sub AddToCellMenu(dummy As Byte)

Dim FilterMenu As CommandBarControl

    ' Delete the controls first to avoid duplicates
    Call DeleteFromCellMenu

    ' Set ContextMenu to the Cell context menu
    ' 31402 is the filter sub-menu of the cell context menu
    Set FilterMenu = Application.CommandBars("Cell").FindControl(ID:=31402)

    ' Add one custom button to the Cell context menu
    With FilterMenu.Controls.Add(Type:=msoControlButton, before:=3)
        .OnAction = "'" & ThisWorkbook.name & "'!" & "InvertFilter"
        .FaceId = 1807
        .Caption = "Invert Filter Selection"
        .Tag = "My_Cell_Control_Tag"
    End With

End Sub

Private Sub DeleteFromCellMenu()

Dim FilterMenu As CommandBarControl
Dim ctrl As CommandBarControl

    ' Set ContextMenu to the Cell context menu
    ' 31402 is the filter sub-menu of the cell context menu
    Set FilterMenu = Application.CommandBars("Cell").FindControl(ID:=31402)

    ' Delete the custom controls with the Tag : My_Cell_Control_Tag
    For Each ctrl In FilterMenu.Controls
        If ctrl.Tag = "My_Cell_Control_Tag" Then
            ctrl.Delete
        End If
    Next ctrl

End Sub

Public Sub InvertFilter()

Dim cell As Range
Dim af As AutoFilter
Dim f As Filter
Dim i As Integer

Dim arrCur As Variant
Dim arrNew As Variant
Dim rngCol As Range
Dim c As Range
Dim txt As String
Dim bBlank As Boolean

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' INITAL CHECKS
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Set cell = ActiveCell
    
    Set af = cell.parent.AutoFilter

    If af Is Nothing Then
        MsgBox "No filters on current sheet"
        Exit Sub
    End If
    
    If Application.Intersect(cell, af.Range) Is Nothing Then
        MsgBox "Current cell not part of filter range"
        Exit Sub
    End If
    
    i = cell.Column - af.Range.cells(1, 1).Column + 1
    Set f = af.Filters(i)
    
    If f.On = False Then
        MsgBox "Current column not being filtered. Nothing to invert"
        Exit Sub
    End If
    
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' GET CURRENT FILTER DATA
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    ' Single value criteria
    If f.Operator = 0 Then
        If f.Criteria1 = "<>" Then ArrayAdd arrNew, "="
        If f.Criteria1 = "=" Then ArrayAdd arrNew, "<>"
        ArrayAdd arrCur, f.Criteria1
    ' Pair of values used as criteria
    ElseIf f.Operator = xlOr Then
        ArrayAdd arrCur, f.Criteria1
        ArrayAdd arrCur, f.Criteria2
    ' Multi list criteria
    ElseIf f.Operator = xlFilterValues Then
        arrCur = f.Criteria1
    Else
        MsgBox "Current filter is not selecting values. Cannot process inversion"
        Exit Sub
    End If
    
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' COMPUTE INVERTED FILTER DATA
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    ' Only process if new list is empty
    ' Being non-empty implies we're just toggling blank state and new list is already determined for that
    If IsEmpty(arrNew) Then
    
        ' Get column of data, ignoring header row
        Set rngCol = af.Range.Resize(af.Range.Rows.Count - 1, 1).Offset(1, i - 1)
        bBlank = False
        
        For Each c In rngCol
            
            ' Ignore blanks for now; they get special processing at the end
            If c.Text <> "" Then
                
                ' If the cell text is in neither the current filter list ...
                txt = "=" & c.Text
                If Not ArrayContains(arrCur, txt) Then
                
                    ' ... nor the new proposed list then add it to the new proposed list
                    If Not ArrayContains(arrNew, txt) Then ArrayAdd arrNew, txt
                
                End If
            
            Else
                ' Record that we have blank cells
                bBlank = True
            End If
            
        Next c
        
        ' Process blank options
        ' If we're not currently selecting for blanks ...
        ' ... and there are blanks ...
        ' ... then filter for blanks in new selection
        If (Not arrCur(UBound(arrCur)) = "=" And bBlank) Then ArrayAdd arrNew, "="
    
    End If
    
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' APPLY NEW FILTER
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    Select Case UBound(arrNew)
        Case 0:
            MsgBox "Didn't find any values to invert"
            Exit Sub
        Case 1:
            af.Range.AutoFilter _
                Field:=i, _
                Criteria1:=arrNew(1)
        Case 2:
            af.Range.AutoFilter _
                Field:=i, _
                Criteria1:=arrNew(1), _
                Criteria2:=arrNew(2), _
                Operator:=xlOr
        Case Else:
            af.Range.AutoFilter _
                Field:=i, _
                Criteria1:=arrNew, _
                Operator:=xlFilterValues
    End Select

End Sub

Private Sub ArrayAdd(ByRef a As Variant, item As Variant)

Dim i As Integer

    If IsEmpty(a) Then
        i = 1
        ReDim a(1 To i)
    Else
        i = UBound(a) + 1
        ReDim Preserve a(1 To i)
    End If
    
    a(i) = item

End Sub

Private Function ArrayContains(a As Variant, item As Variant) As Boolean

Dim i As Integer

    If IsEmpty(a) Then
        ArrayContains = False
        Exit Function
    End If
    
    For i = LBound(a) To UBound(a)
        If a(i) = item Then
            ArrayContains = True
            Exit Function
        End If
    Next i
    
    ArrayContains = False

End Function

' Used to find the menu IDs
Private Sub ListMenuInfo()

Dim row As Integer
Dim Menu As CommandBarControl
Dim MenuItem As CommandBarControl
Dim SubMenuItem As CommandBarControl

    row = 1
    On Error Resume Next
    For Each Menu In CommandBars("cell").Controls
        For Each MenuItem In Menu.Controls
            For Each SubMenuItem In MenuItem.Controls
                cells(row, 1) = Menu.Caption
                cells(row, 2) = Menu.ID
                cells(row, 3) = MenuItem.Caption
                cells(row, 4) = MenuItem.ID
                cells(row, 5) = SubMenuItem.Caption
                cells(row, 6) = SubMenuItem.ID
                row = row + 1
            Next SubMenuItem
        Next MenuItem
    Next Menu
    
End Sub

слэн,  
я вчера поковырялся с этим немного. Если условие представлено в виде criteria1, criteria2, его можно инвертировать в том же виде, например  
=a ИЛИ =b -> <>a И <>b  
>a И <=b -> <=a ИЛИ >b  

  А со списком есть тонкость. Если на таблицу наложен фильтр только в одном столбце, это действительно работает — составить коллекцию (dictionary) уникальных, исключить из нее элементы из массива Criteria1, применить фильтр с  
Criteria1:=dictionary.keys.  
Но если на таблицу наложен фильтр в других столбцах, такой метод может давать «лишние» элементы, которые скрыты другими фильтрами. И в этом случае после применения фильтра ничего не отображается. Я на этом остановился вчера.  
Видимо, после сохранения массива Criteria1 надо снимать фильтр с этого столбца и составлять коллекцию из уникальных ВИДИМЫХ элементов, потом по этой же схеме.  

  Да, еще для 2007 надо предусмотреть работу с автофильтрами в таблицах (Listobjects).  
Сейчас некогда, а задачка в общем интересная. Особенно при одновременной инверсии условия в нескольких столбцах

Предположим, вы выбрали некоторые определенные ячейки диапазона, и теперь вам нужно инвертировать выделение: отменить выбор выбранных ячеек и выбрать другие ячейки. См. Следующий снимок экрана:

Конечно, вы можете отменить выбор вручную. Но в этой статье вы найдете несколько забавных приемов, позволяющих быстро отменить выбор:

Обратный выбор в Excel с VBA

Обратный выбор в Excel с помощью Kutools for Excel

Обратный выбор в Excel с VBA

Использование макроса VBA упростит вам работу по отмене выбора в рабочей области активного листа.

Step1: Выберите ячейки, которые вы хотите перевернуть.

Step2: Удерживайте другой + F11 ключи в Excel, и он открывает Microsoft Visual Basic для приложений окно.

Step3: Нажмите Вставить > Модулии вставьте следующий макрос в окно модуля.

VBA для инвертирования выделений

Sub InvertSelection()
'Updateby20140314
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim OutRng As Range
xTitleId = "KutoolsforExcel"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Range1 :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Range2", xTitleId, Type:=8)
For Each rng In Rng2
    If Application.Intersect(rng, Rng1) Is Nothing Then
        If OutRng Is Nothing Then
            Set OutRng = rng
        Else
            Set OutRng = Application.Union(OutRng, rng)
        End If
    End If
Next
OutRng.Select
End Sub
	

Step4: Нажмите F5 ключ для запуска этого макроса. Затем отображается диалоговое окно, в котором вы можете выбрать некоторые ячейки, которые вам не нужно выбирать в результате. Смотрите скриншот:

Шаг 5: Нажмите OK, и выберите диапазон, в котором вы хотите отменить выбор, в другом всплывающем диалоговом окне. Смотрите скриншот:

Шаг 6: Нажмите OK. вы можете видеть, что выбор был отменен.

Ноты: Этот VBA также работает с пустым листом.

Обратный выбор в Excel с помощью Kutools for Excel

Вы можете быстро отменить любой выбор в Excel, Выбрать помощника по диапазону инструменты Kutools for Excel может помочь вам быстро отменить выбор в Excel. Этот трюк позволяет легко отменить любой выбор во всей книге.

Kutools for Excel включает более 300 удобных инструментов Excel. Бесплатная пробная версия без ограничений в течение 30 дней. Получить сейчас.

Step1: Выберите ячейки, которые вы хотите перевернуть.

Step2: Нажмите Кутулс > Выберите Инструменты > Выбрать помощника по диапазону….

Step3В Выбрать помощника по диапазону диалоговое окно, проверьте Обратный выбор опцию.

Step4: Затем перетащите мышь, чтобы выбрать диапазон, в котором вы хотите отменить выбор. Когда вы отпустите кнопку мыши, выделенные ячейки будут отменены, а невыделенные ячейки будут сразу выбраны из диапазона.

Step5: А затем закройте Выбрать помощника по диапазону диалоговое окно.

Для получения более подробной информации о Выбрать помощника по диапазону, Пожалуйста, посетите Описание функции Select Range Helper.

Статьи по теме:

• Выберите несмежные ячейки или диапазоны
• Отменить выбор ячеек из выбранных диапазонов
• Выбрать все ячейки с данными в выборках

Option Explicit
 
Dim alArrBegRows(), alArrEndRows(), alArrBegCols(), alArrEndCols()
Dim lMinRow As Long, lMaxRow As Long, lMinCol As Long, lMaxCol As Long
Sub Invert_Selection()
    Dim rArea As Range, rInvertRange As Range, rTmpRng As Range, rRng As Range
    Dim lr As Long, lc As Long, li As Long
    Dim lEndRow As Long, lEndCol As Long
    Dim bEqualRows As Boolean, bEqualCols As Boolean
 
    If TypeName(Selection) <> "Range" Then Exit Sub
    For Each rArea In Selection.Areas
        ReDim Preserve alArrBegRows(li), alArrEndRows(li), alArrBegCols(li), alArrEndCols(li)
        alArrBegRows(li) = rArea.Row: alArrEndRows(li) = rArea.Row + rArea.Rows.Count - 1
        alArrBegCols(li) = rArea.Column: alArrEndCols(li) = rArea.Column + rArea.Columns.Count - 1
        li = li + 1
    Next rArea
    lMinRow = alArrBegRows(0): lMaxRow = 0: lMinCol = alArrBegCols(0): lMaxCol = 0
    For li = 0 To UBound(alArrBegRows)
        If alArrBegRows(li) < lMinRow Then lMinRow = alArrBegRows(li)
        If alArrEndRows(li) > lMaxRow Then lMaxRow = alArrEndRows(li)
        If alArrBegCols(li) < lMinCol Then lMinCol = alArrBegCols(li)
        If alArrEndCols(li) > lMaxCol Then lMaxCol = alArrEndCols(li)
    Next li
    lEndRow = ActiveSheet.Rows.Count
    lEndCol = ActiveSheet.Columns.Count
    'максимальные пороги
    If lMaxRow <> lEndRow Then
        Set rInvertRange = Rows(lMaxRow + 1 & ":" & lEndRow)
    End If
    If lMaxCol <> lEndCol Then
        If Not rInvertRange Is Nothing Then
            Set rInvertRange = Union(rInvertRange, Range(Cells(1, lMaxCol + 1), Cells(1, lEndCol)).EntireColumn)
        Else
            Set rInvertRange = Range(Cells(1, lMaxCol + 1), Cells(1, lEndCol)).EntireColumn
        End If
    End If
    'минимальные пороги
    If lMinRow <> 1 Then
        If Not rInvertRange Is Nothing Then
            Set rInvertRange = Union(rInvertRange, Rows(1 & ":" & lMinRow - 1))
        Else
            Set rInvertRange = Rows(1 & ":" & lMinRow - 1)
        End If
    End If
    If lMinCol <> 1 Then
        If Not rInvertRange Is Nothing Then
            Set rInvertRange = Union(rInvertRange, Range(Cells(1, 1), Cells(1, lMinCol - 1)).EntireColumn)
        Else
            Set rInvertRange = Range(Cells(1, 1), Cells(1, lMinCol - 1)).EntireColumn
        End If
    End If
 
    For li = 0 To UBound(alArrBegRows)
        'Если выделен целый столбец/столбцы
        If alArrEndRows(li) = lEndRow And alArrBegRows(li) = 1 Then
            bEqualRows = 1
        Else
            bEqualRows = 0
        End If
        'Если выделена целая строка/строки
        If alArrEndCols(li) = lEndCol And alArrBegCols(li) = 1 Then
            bEqualCols = 1
        Else
            bEqualCols = 0
        End If
    Next li
    'Если выделены даже несвязанные строки/столбцы целиком
    If bEqualRows Then lMinRow = lMaxRow
    If bEqualCols Then lMinCol = lMaxCol
    'ячейки "внутри"
    For lr = lMinRow To lMaxRow
        For lc = lMinCol To lMaxCol
            If Intersect_Nums(lr, lc) = False Then
                If rRng Is Nothing Then
                    If lMinRow = lMaxRow Then
                        Set rRng = Cells(lr, lc).EntireColumn
                    Else
                        If lMinCol = lMaxCol Then
                            Set rRng = Cells(lr, lc).EntireRow
                        Else
                            Set rRng = Cells(lr, lc)
                        End If
                    End If
                Else
                    If lMinRow = lMaxRow Then
                        Set rRng = Union(rRng, Cells(lr, lc).EntireColumn)
                    Else
                        If lMinCol = lMaxCol Then
                            Set rRng = Union(rRng, Cells(lr, lc).EntireRow)
                        Else
                            Set rRng = Union(rRng, Cells(lr, lc))
                        End If
                    End If
                End If
            End If
        Next lc
    Next lr
    If Not rInvertRange Is Nothing Then
        If Not rRng Is Nothing Then
            Set rInvertRange = Union(rRng, rInvertRange)
        End If
    Else
        If Not rRng Is Nothing Then
            Set rInvertRange = rRng
        End If
    End If
 
    'Действия над инвертированным диапазоном
    If Not rInvertRange Is Nothing Then
        rInvertRange.Select
    End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : Intersect_Nums
' Purpose   : Функция определения вхождения в диапазон
'---------------------------------------------------------------------------------------
Function Intersect_Nums(lr As Long, lc As Long) As Boolean
    Dim lCntR As Long, lCntC As Long, li As Long
    For li = LBound(alArrBegRows) To UBound(alArrBegRows)
        For lCntR = alArrBegRows(li) To alArrEndRows(li)
            For lCntC = alArrBegCols(li) To alArrEndCols(li)
                If lr = lCntR Then
                    If lc = lCntC Then Intersect_Nums = True: Exit Function
                End If
            Next lCntC
        Next lCntR
    Next li
End Function

Код

Sub InvertSelection2()
      ‘—————————————————————————————
      ‘ Procedure : InvertSelection
      ‘ Author    :
      ‘ URL       : http://www.planetaexcel.ru/forum.php?thread_id=14008
      ‘ DateTime  : 04.03.2010   00:17
      ‘ Purpose   : инвертировать Selection
      ‘ Notes     : Работает со всеми ячейками листа, поддерживается выделение нескольких несмежных диапазонов.
      ‘ Notes     : в процессе работы создаётся временная КНИГА, поэтому работает в том числе и при защищенной структуре книги
      ‘—————————————————————————————
      If Not TypeName(Selection) = «Range» Then Exit Sub
      With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
      Dim selAddr As String: selAddr = Selection.Address
      With ActiveSheet
         With Workbooks.Add
            With ActiveSheet
               .Cells.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=»0″
               .Range(selAddr).ClearFormats
               selAddr = .Cells.SpecialCells(xlCellTypeAllFormatConditions).Address
            End With
            .Close False
         End With
         .Range(selAddr).Select
      End With
      With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
End Sub