MS Excel autofilter helpers

'MS Excel autofilter helpers
'Bruce Leyden Aug 2015
'pastebin_vba@f.blackworx.co.uk

'NB: This code will not compile for versions of XL prior to 2007.
'(Not tested with Mac versions)

'Suggested keyboard shortcuts:
'Ctrl+Shift+J - FilterBySelection
'Ctrl+Shift+K - ClearFiltersOnly

Sub ClearFiltersOnly()
'Alternative to built-in "clear all filters" command for XL2007 onwards.
'Removes autofilter criteria from current worksheet/table without removing sort criteria.

'If worksheet contains multiple table objects, or at least one table plus a
'filtered basic range, intended target is located by testing current selection.

'Takes no action and fails silently on any error condition.

'Bruce Leyden Aug 2015

Dim xlcUserCalcMode As XlCalculation
Dim shtTgt As Worksheet
Dim rTest As Range

    On Error GoTo ClearFiltersOnly_Exit

    xlcUserCalcMode = Application.Calculation

    Set shtTgt = ActiveSheet

    If TypeName(Selection) = "Range" Then Set rTest = Selection.Cells(1) Else Set rTest = Nothing

    With shtTgt

        If .Type <> xlWorksheet Then Exit Sub

        If .ProtectContents And Not .Protection.AllowFiltering Then Exit Sub

        If .AutoFilterMode Then

            If .ListObjects.Count = 0 Then

                Call ClearBasicFilter(shtTgt)

            Else

                If Not ClearTableFilter(shtTgt, rTest) Then Call ClearBasicFilter(shtTgt)

            End If

        ElseIf .ListObjects.Count > 0 Then

            Call ClearTableFilter(shtTgt, rTest)

        End If

    End With

ClearFiltersOnly_Exit:
    Err.Clear
    Application.ScreenUpdating = True
    Application.Calculation = xlcUserCalcMode
End Sub

Private Sub ClearBasicFilter(shtTgt As Worksheet)
Dim rFilt As Range
Dim Index As Long

    On Error Resume Next

    Set rFilt = shtTgt.AutoFilter.Range

    Application.ScreenUpdating = False 'Prevent screen flicker
    Application.Calculation = xlCalculationManual 'Prevent slowdown with lots of filtered data/formulae

    For Index = 1 To rFilt.Columns.Count
        If shtTgt.AutoFilter.Filters(Index).On Then rFilt.AutoFilter Field:=Index
        If Err.number <> 0 Then Err.Clear 'Shouldn't happen, but just in case
    Next Index

End Sub

Private Function ClearTableFilter(shtTgt As Worksheet, Optional rTest As Range = Nothing) As Boolean
Dim Index As Long

    ClearTableFilter = False

    Index = 1

    With shtTgt

        If Not rTest Is Nothing Then

            On Error GoTo NoMatchFound

            Do While Intersect(.ListObjects(Index).Range, rTest) Is Nothing
                Index = Index + 1
            Loop

            On Error GoTo 0

        End If

        If .ListObjects(Index).ShowAutoFilter Then
            Application.Calculation = xlCalculationManual 'Prevent slowdown with lots of filtered data/formulae
            .ListObjects(Index).AutoFilter.ShowAllData
        End If

    End With

    ClearTableFilter = True

NoMatchFound:
End Function

Sub FilterBySelection()
'Filters current column by selection (same as right-click > filter > filter by selected cell's value)
'If autofilter not active on current region then it will be activated as a result of running this
'Bruce Leyden Aug 2015

Dim shtTgt As Worksheet
Dim rTgt As Range
Dim rTest As Range
Dim Index As Long

    On Error GoTo FilterBySelection_Err

    Set shtTgt = ActiveSheet

    If TypeName(Selection) = "Range" Then Set rTest = Selection.Cells(1) Else Exit Sub

    Set rTgt = CurrentArea(shtTgt, rTest)

    If rTgt Is Nothing Then
        Set rTgt = rTest.CurrentRegion
        If rTgt.Rows.Count < 2 Then Exit Sub
    End If

    With rTgt
        Index = rTest.Column - .Column + 1
        .AutoFilter Field:=Index, Criteria1:=rTest.Value
    End With

FilterBySelection_Err:
End Sub

Private Function CurrentArea(shtTgt As Worksheet, Optional rTest As Range = Nothing) As Range
'Returns the range or table range, within shtTgt, which rTest falls under

'If rTest is omitted, then CurrentArea returns autofiltered range or table,
'ONLY if there is a single instance of either one or the other within shtTgt.

'Fails silently (CurrentArea=Nothing) on error.

'Bruce Leyden Aug 2015

Dim Index As Long

    Set CurrentArea = Nothing

    On Error GoTo CurrentArea_Err

    With shtTgt

        If rTest Is Nothing Then

            If .ListObjects.Count = 1 Xor .AutoFilterMode Then

                If .AutoFilterMode Then
                    Set CurrentArea = .AutoFilter.Range
                Else
                    Set CurrentArea = .ListObjects(1).Range
                End If

            End If

        Else

            If .AutoFilterMode Then

                If Not Intersect(rTest, .AutoFilter.Range) Is Nothing Then
                    Set CurrentArea = .AutoFilter.Range
                    Exit Function
                End If

            End If

            If .ListObjects.Count > 0 Then

                For Index = 1 To .ListObjects.Count
                    If Not Intersect(rTest, .ListObjects(Index).Range) Is Nothing Then
                        Set CurrentArea = .ListObjects(Index).Range
                        Exit Function
                    End If
                Next Index

            End If

        End If

    End With

CurrentArea_Err:
End Function