在 Excel 中反转筛选器选择

Question

我正在问一个我打算回答的问题，以便我可以以持久的方式记录这个问题。非常乐意其他人提出其他建议/更正。

我在 Excel 中经常遇到一个问题，我使用过滤器，然后想要反转选择，即取消选择所有已选择的项目并选择当前未选择的所有项目。例如，请参阅下面的屏幕截图：

除了点击列表之外，没有简单的方法可以做到这一点（据我所知！），这既费力又容易出错。我们如何在 Excel 中自动实现此功能？

前：

后：

Answer 1

我编写了一些 VBA 来扩展 Excel 并提供此功能。它在“过滤器”子菜单中添加了一个新的上下文菜单（右键单击菜单）选项（参见屏幕截图）。

您需要调用AddToCellMenu子例程来使菜单项出现。如果您想对所有 Excel 会话进行永久设置，则需要将此代码放入您正在运行的个人工作簿或加载项中，然后调用该AddToCellMenu事件Workbook_Open或类似的内容。

无论如何，这是代码：

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