1
\$\begingroup\$

I had been searching for a way to print an Excel sheet's Autofilter settings to the Immediate window and I came up with this. This allows a developer to quickly convert an end user's filter settings to VBA code. I would appreciate feedback from anyone who cares to test the code. 

Option Explicit
Public ws As Worksheet
Public wsn As String
Public MyCrit As Variant
Public FirstCritRow As Long
Public MiddleCritRow As Long
Public LastCritRow As Long
Public c As Long
Public MyRank As Double

Sub PrintFilters()

'Peter Domanico, November 2017 - January 2018
'Prints Excel Autofilter settings as VBA code to Immediate Window
'This file contains 3 scripts. use this code in own module.
'Assign the primary script (PrintFilters) to Excel button or shortcut key
'Primary script (PrintFilters) calls subscripts TopTenSub and BottomTenSub

'performance
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

'sheet dims
    Set ws = ActiveSheet '<~leave out "ThisWorkbook": causes errors with personal macro workbook
    wsn = ws.Name

'rows and columns
    Dim LastRow As Long
    Dim AllRows As Long
    Dim DataRows As Long
    Dim LastCol As Long
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    AllRows = ws.UsedRange.Rows.Count
    DataRows = AllRows - 1
    LastCol = ws.UsedRange.Columns.Count

'for use in xlTop10Items / xlBottom10Items
    Dim VisRows As Long
    VisRows = Application.WorksheetFunction.Subtotal(3, Range("A2:A" & LastRow))

'for use in xlFilterValues
    Dim CritString As String
    Dim AllCrit As Variant
    Dim CritVar As Variant

'for use in xlFilterCellColor
    Dim CondishCount As Long
    Dim ClrString As String

'misc dims
    Dim FltrCt As Long

 'begin main procedure
    FltrCt = 0 '<~ keeps count of active filters
    For c = 1 To LastCol '<~loop through each column
    On Error Resume Next  '<~error handling

    With ws.AutoFilter.Filters(c) '<~uses filtered range only
        Select Case .Operator  '<~detects operator type by value
            Case Is = 0 '<~Equals
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & Chr(34) & .Criteria1 & Chr(34)

            Case Is = 1 '<~xlAnd
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & Chr(34) & .Criteria1 & Chr(34) & Chr(44) & "Operator:=xlAnd" & Chr(44) & ("Criteria2:=" & Chr(34) & .Criteria2 & Chr(34))

            Case Is = 2 '<~xlOr
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & Chr(34) & .Criteria1 & Chr(34) & Chr(44) & "Operator:=xlOr" & Chr(44) & ("Criteria2:=" & Chr(34) & .Criteria2 & Chr(34))

            Case Is = 3 'xlTop10Items
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & VisRows & Chr(44) & "Operator:=xlTop10Items"

            Case Is = 4 'xlBottom10Items
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & VisRows & Chr(44) & "Operator:=xlBottom10Items"

            Case Is = 5 'xlTop10Percent
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                MyCrit = Mid(.Criteria1, 3)
                Call TopTenSub
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyRank & Chr(44) & "Operator:=xlTop10Percent"

            Case Is = 6 'xlBottom10Percent
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                MyCrit = Mid(.Criteria1, 3)
                Call BottomTenSub
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyRank & Chr(44) & "Operator:=xlBottom10Percent"

            Case Is = 7 '<~xlFilterValues
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                For Each CritVar In .Criteria1
                    AllCrit = AllCrit & Chr(44) & Chr(34) & Mid(CritVar, 2) & Chr(34)
                    CritString = AllCrit
                    CritString = Replace(CritString, Chr(44), "", 1, 1)
                Next
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=Array(" & CritString & ")," & "Operator:=xlFilterValues"
                AllCrit = Nothing

            Case Is = 8 '<~xlFilterCellColor
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                ClrString = ws.Cells(LastRow, c).Interior.Color '<~ filters by manually applied cell fill color
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & ClrString & Chr(44) & "Operator:=xlFilterCellColor"
                CondishCount = ws.Cells(LastRow, c).FormatConditions.Count
                If CondishCount > 0 Then Debug.Print Chr(39) & CondishCount & Chr(32) & "conditional formats detected in column" & Chr(32) & c

             Case Is = 9 '<~xlFilterFontColor
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                ClrString = ws.Cells(LastRow, c).Font.Color '<~ filters by manually applied cell fill color
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & ClrString & Chr(44) & "Operator:=xlFilterFontColor"

            Case Is = 11
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                MyCrit = .Criteria1
                If MyCrit = 33 Then MyCrit = "xlFilterAboveAverage"
                If MyCrit = 34 Then MyCrit = "xlFilterBelowAverage"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyCrit & Chr(44) & "Operator:=xlFilterDynamic"
        End Select
    End With

    Next c

'close With statement
    If FltrCt > 0 Then Debug.Print "End With"

'performance and cleanup
    ws.Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Sub TopTenSub()

'set sheets
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim TempSheet As Worksheet
    Set ws = wb.Sheets(wsn)
    Dim LastRow As Long

 'duplicate source sheet
    On Error Resume Next
    wb.Sheets("PeteDTempData").Delete
    wb.Sheets(wsn).Copy After:=wb.Sheets(wsn)
    wb.ActiveSheet.Name = "PeteDTempData"
    Set TempSheet = wb.Sheets("PeteDTempData")

 'sort
    TempSheet.UsedRange.AutoFilter
    LastRow = TempSheet.Cells(Rows.Count, 1).End(xlUp).Row
    TempSheet.Sort.SortFields.Add Key:=Range("A2:A" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With TempSheet.Sort
        .SetRange Range("A1:A" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'number range
    Dim j As Long
    Dim i As Long
    Dim CountCol As Long

    CountCol = TempSheet.UsedRange.Columns.Count + 1

    j = 1
    For i = 2 To LastRow
        TempSheet.Cells(i, CountCol) = j
    j = j + 1
    Next i

'find first MyCrit
    FirstCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole).Row

'find last MyCrit
    LastCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole, SearchDirection:=xlPrevious).Row

'find middle MyCrit
    MiddleCritRow = WorksheetFunction.Average(FirstCritRow, LastCritRow)
        MiddleCritRow = Round(MiddleCritRow, 0)

'calculate percent
    With TempSheet
        MyRank = .Cells(MiddleCritRow, CountCol) / (LastRow - 1)
            MyRank = MyRank * 100
                MyRank = Round(MyRank, 0)
    End With

'delete temp sheet
    TempSheet.Delete
    ws.Select

End Sub

Sub BottomTenSub()

'set sheets
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim TempSheet As Worksheet
    Set ws = wb.Sheets(wsn)
    Dim LastRow As Long

 'duplicate source sheet
    On Error Resume Next
    wb.Sheets("PeteDTempData").Delete
    wb.Sheets(wsn).Copy After:=wb.Sheets(wsn)
    wb.ActiveSheet.Name = "PeteDTempData"
    Set TempSheet = wb.Sheets("PeteDTempData")

 'sort
    TempSheet.UsedRange.AutoFilter
    LastRow = TempSheet.Cells(Rows.Count, 1).End(xlUp).Row
    TempSheet.Sort.SortFields.Add Key:=Range("A2:A" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With TempSheet.Sort
        .SetRange Range("A1:A" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'number range
    Dim j As Long
    Dim i As Long
    Dim CountCol As Long

    CountCol = TempSheet.UsedRange.Columns.Count + 1

    j = 1
    For i = 2 To LastRow
        TempSheet.Cells(i, CountCol) = j
    j = j + 1
    Next i

'find first MyCrit
    FirstCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole).Row

'find last MyCrit
    LastCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole, SearchDirection:=xlPrevious).Row

'find middle MyCrit
    MiddleCritRow = WorksheetFunction.Average(FirstCritRow, LastCritRow)
        MiddleCritRow = Round(MiddleCritRow, 0)

'calculate percent
    With TempSheet
        MyRank = .Cells(MiddleCritRow, CountCol) / (LastRow - 1)
            MyRank = 1 - MyRank
                MyRank = MyRank * 100
                    MyRank = Round(MyRank, 0)
    End With

'delete temp sheet
    TempSheet.Delete
    ws.Select

End Sub
Improve this question
\$\endgroup\$

2 Answers 2

Reset to default
1
\$\begingroup\$

Printing Excel Autofilter setting is a great idea. The problem with your implementation is that too much of it is hardcoded.

'Range("A2:A" & LastRow)' needs to be fully-qualified ws. Range("A2:A" & LastRow)

There are a lot of caveats to the Autofilter. Here is the foundation that I would use:

Sub PrintFilters(ws As Worksheet)
    Dim AutoFilter1 As AutoFilter
    Dim Criteria1 As String, Criteria2 As String, Operator1 As String
    Dim FieldIndex As Long

    Set AutoFilter1 = ws.AutoFilter
    If Not AutoFilter1 Is Nothing Then
        For FieldIndex = 1 To AutoFilter1.Filters.Count
            If AutoFilter1.Filters(FieldIndex).On Then
                With AutoFilter1.Filters(FieldIndex)
                    On Error Resume Next
                    Criteria1 = getCriteria(.Criteria1)
                    Criteria2 = getCriteria(.Criteria2)
                    Operator1 = getXlAutoFilterOperator(.Operator)
                    On Error GoTo 0

                End With
            End If
        Next
    End If
End Sub

Function getCriteria(Criteria As Variant) As String
    On Error Resume Next
    ' Criteria can return either a scalar value or an Array.  You'll have to handle both cases
    On Error GoTo 0
End Function

Function getXlDynamicFilterCriteria(Index As Long)
    Dim s As String
    Select Case Index
        Case 33: s = "xlFilterAboveAverage"           'Filter all above-average values.
        Case 24: s = "xlFilterAllDatesInPeriodApril"  'Filter all dates in April.
        Case 28: s = "xlFilterAllDatesInPeriodAugust"    'Filter all dates in August.
        Case 32: s = "xlFilterAllDatesInPeriodDecember"    'Filter all dates in December.
        Case 22: s = "xlFilterAllDatesInPeriodFebruray"    'Filter all dates in February.
        Case 21: s = "xlFilterAllDatesInPeriodJanuary"    'Filter all dates in January.
        Case 27: s = "xlFilterAllDatesInPeriodJuly"   'Filter all dates in July.
        Case 26: s = "xlFilterAllDatesInPeriodJune"   'Filter all dates in June.
        Case 23: s = "xlFilterAllDatesInPeriodMarch"  'Filter all dates in March.
        Case 25: s = "xlFilterAllDatesInPeriodMay"    'Filter all dates in May.
        Case 31: s = "xlFilterAllDatesInPeriodNovember"    'Filter all dates in November.
        Case 30: s = "xlFilterAllDatesInPeriodOctober"    'Filter all dates in October.
        Case 17: s = "xlFilterAllDatesInPeriodQuarter1"    'Filter all dates in Quarter1.
        Case 18: s = "xlFilterAllDatesInPeriodQuarter2"    'Filter all dates in Quarter2.
        Case 19: s = "xlFilterAllDatesInPeriodQuarter3"    'Filter all dates in Quarter3.
        Case 20: s = "xlFilterAllDatesInPeriodQuarter4"    'Filter all dates in Quarter4.
        Case 29: s = "xlFilterAllDatesInPeriodSeptember"    'Filter all dates in September.
        Case 34: s = "xlFilterBelowAverage"           'Filter all below-average values.
        Case 8: s = "xlFilterLastMonth"               'Filter all values related to last month.
        Case 11: s = "xlFilterLastQuarter"            'Filter all values related to last quarter.
        Case 5: s = "xlFilterLastWeek"                'Filter all values related to last week.
        Case 14: s = "xlFilterLastYear"               'Filter all values related to last year.
        Case 9: s = "xlFilterNextMonth"               'Filter all values related to next month.
        Case 12: s = "xlFilterNextQuarter"            'Filter all values related to next quarter.
        Case 6: s = "xlFilterNextWeek"                'Filter all values related to next week.
        Case 15: s = "xlFilterNextYear"               'Filter all values related to next year.
        Case 7: s = "xlFilterThisMonth"               'Filter all values related to the current month.
        Case 10: s = "xlFilterThisQuarter"            'Filter all values related to the current quarter.
        Case 4: s = "xlFilterThisWeek"                'Filter all values related to the current week.
        Case 13: s = "xlFilterThisYear"               'Filter all values related to the current year.
        Case 1: s = "xlFilterToday"                   'Filter all values related to the current date.
        Case 3: s = "xlFilterTomorrow"                'Filter all values related to tomorrow.
        Case 16: s = "xlFilterYearToDate"             'Filter all values from today until a year ago.
        Case 2: s = "xlFilterYesterday"               'Filter all values related to yesterday.
    End Select
    getXlDynamicFilterCriteria = s
End Function

Function getXlAutoFilterOperator(Index As Long)
    Dim s As String
    Select Case Index
        Case 1: s = "xlAnd"                           'Logical AND of Criteria1 and Criteria2.
        Case 4: s = "xlBottom10Items"                 'Lowest-valued items displayed (number of items specified in Criteria1).
        Case 6: s = "xlBottom10Percent"               'Lowest-valued items displayed (percentage specified in Criteria1).
        Case 8: s = "xlFilterCellColor"               'Color of the cell
        Case 11: s = "xlFilterDynamic"                'Dynamic filter
        Case 9: s = "xlFilterFontColor"               'Color of the font
        Case 10: s = "xlFilterIcon"                   'Filter icon
        Case 7: s = "xlFilterValues"                  'Filter values
        Case 2: s = "xlOr"                            'Logical OR of Criteria1 or Criteria2.
        Case 3: s = "xlTop10Items"                    'Highest-valued items displayed (number of items specified in Criteria1).
        Case 5: s = "xlTop10Percent"                  'Highest-valued items displayed (percentage specified in Criteria1).
    End Select
    getXlAutoFilterOperator = s
End Function
Improve this answer
\$\endgroup\$
0
0
\$\begingroup\$

I have integrated some of Thomas's ideas here. I just noticed my code has trouble with arrays of dates, which I will need to work on. Generally speaking, this seems to work well. 

Option Explicit
Public Ws As Worksheet
Public wsn As String
Public s As String
Public MyCrit As Variant
Public FirstCritRow As Long
Public MiddleCritRow As Long
Public LastCritRow As Long
Public c As Long
Public MyRank As Double

Sub PrintFilters()

'Peter Domanico, November 2017 - January 2018
'Prints Excel Autofilter settings as VBA code to Immediate Window
'This file contains 6 scripts. Use this code in own module.
'Assign the primary script (PrintFilters) to Excel button or shortcut key
'Primary script (PrintFilters) calls all other scripts

'performance
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

'sheet dims
    Set Ws = ActiveSheet '<~leave out "ThisWorkbook": causes errors with personal macro workbook
    wsn = Ws.Name

'rows and columns
    Dim LastRow As Long
    Dim LastCol As Long
    LastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = Ws.UsedRange.Columns.Count

'for use in xlFilterValues
    Dim CritString As String
    Dim AllCrit As Variant
    Dim CritVar As Variant

'for use in xlFilterCellColor
    Dim CondishCount As Long
    Dim ClrString As String

'misc dims
    Dim FltrCt As Long

 'begin main procedure
    FltrCt = 0 '<~ keeps count of active filters
    For c = 1 To LastCol '<~loop through each column
    On Error Resume Next  '<~error handling

    With Ws.AutoFilter.Filters(c) '<~uses filtered range only
        Select Case .Operator  '<~detects operator type by value
            Case Is = 0 '<single filter value
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & Chr(34) & .Criteria1 & Chr(34)

            Case Is = 1 '<~xlAnd
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & Chr(34) & .Criteria1 & Chr(34) & Chr(44) & "Operator:=xlAnd" & Chr(44) & ("Criteria2:=" & Chr(34) & .Criteria2 & Chr(34))

            Case Is = 2 '<~xlOr
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & Chr(34) & .Criteria1 & Chr(34) & Chr(44) & "Operator:=xlOr" & Chr(44) & ("Criteria2:=" & Chr(34) & .Criteria2 & Chr(34))

            Case Is = 3 'xlTop10Items
                FltrCt = FltrCt + 1
                MyCrit = Mid(.Criteria1, 3)
                Call TopTenItemSub
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyRank & Chr(44) & "Operator:=xlTop10Items"

            Case Is = 4 'xlBottom10Items
                FltrCt = FltrCt + 1
                MyCrit = Mid(.Criteria1, 3)
                Call BottomTenItemSub
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyRank & Chr(44) & "Operator:=xlBottom10Items"

            Case Is = 5 'xlTop10Percent
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                MyCrit = Mid(.Criteria1, 3)
                Call TopTenPercSub
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyRank & Chr(44) & "Operator:=xlTop10Percent"

            Case Is = 6 'xlBottom10Percent
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                MyCrit = Mid(.Criteria1, 3)
                Call BottomTenPercSub
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & MyRank & Chr(44) & "Operator:=xlBottom10Percent"

            Case Is = 7 '<~xlFilterValues
                Select Case IsDate(Ws.Cells(2, c))
                    Case Is = True
                        Debug.Print Chr(39) & "Unsupported date array found in column " & c & Chr(46) & Chr(32) & "Please inspect Autofilter manually" & Chr(46)
                        GoTo DateBail
                End Select

                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                For Each CritVar In .Criteria1
                    AllCrit = AllCrit & Chr(44) & Chr(34) & Mid(CritVar, 2) & Chr(34)
                    CritString = AllCrit
                    CritString = Replace(CritString, Chr(44), "", 1, 1)
                Next
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=Array(" & CritString & ")," & "Operator:=xlFilterValues"
                AllCrit = Nothing

            Case Is = 8 '<~xlFilterCellColor
                FltrCt = FltrCt + 1
                CondishCount = Ws.Cells(LastRow, c).FormatConditions.Count
                If CondishCount > 0 Then Debug.Print Chr(39) & CondishCount & Chr(32) & "conditional format(s) detected in column" & Chr(32) & c & Chr(46) & Chr(32) & "Please inspect Autofilter manually" & Chr(46)
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                ClrString = Ws.Cells(LastRow, c).Interior.Color '<~ filters by manually applied cell fill color
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & ClrString & Chr(44) & "Operator:=xlFilterCellColor"

             Case Is = 9 '<~xlFilterFontColor
                FltrCt = FltrCt + 1
                CondishCount = Ws.Cells(LastRow, c).FormatConditions.Count
                If CondishCount > 0 Then Debug.Print Chr(39) & CondishCount & Chr(32) & "conditional format(s) detected in column" & Chr(32) & c & Chr(46) & Chr(32) & "Please inspect Autofilter manually" & Chr(46)
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                ClrString = Ws.Cells(LastRow, c).Font.Color '<~ filters by manually applied cell fill color
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & ClrString & Chr(44) & "Operator:=xlFilterFontColor"

            Case Is = 11 '<~xlFilterDynamic
                FltrCt = FltrCt + 1
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                MyCrit = .Criteria1
                Call DynamicSub
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Criteria1:=" & s & Chr(44) & "Operator:=xlFilterDynamic"

            Case Is = 12 '<~xlFilterNoFill
                FltrCt = FltrCt + 1
                CondishCount = Ws.Cells(LastRow, c).FormatConditions.Count
                If CondishCount > 0 Then Debug.Print Chr(39) & CondishCount & Chr(32) & "conditional format(s) detected in column" & Chr(32) & c & Chr(46) & Chr(32) & "Please inspect Autofilter manually" & Chr(46)
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Operator:=xlFilterNoFill"

            Case Is = 13 '<~xlFilterAutomaticFontColor
                FltrCt = FltrCt + 1
                CondishCount = Ws.Cells(LastRow, c).FormatConditions.Count
                If CondishCount > 0 Then Debug.Print Chr(39) & CondishCount & Chr(32) & "conditional format(s) detected in column" & Chr(32) & c & Chr(46) & Chr(32) & "Please inspect Autofilter manually" & Chr(46)
                If FltrCt = 1 Then Debug.Print "With " & "Sheets(" & Chr(34) & wsn & Chr(34) & Chr(41) & ".UsedRange"
                Debug.Print vbTab & ".Autofilter Field:=" & c & Chr(44) & "Operator:=xlFilterAutomaticFontColor"
        End Select
    End With

DateBail:
    Next c

'close With statement and notify user
    Select Case FltrCt
        Case Is > 0
            Debug.Print "End With"
            MsgBox FltrCt & " supported filters detected", vbInformation, "See Immediate Window for code"
    End Select

'notify user if no filtered columns detected
    If FltrCt = 0 Then MsgBox "No filtered columns detected", vbInformation, "!!!"

'performance and cleanup
    Ws.Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Sub TopTenItemSub()

'set sheets
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim TempSheet As Worksheet
    Set Ws = wb.Sheets(wsn)
    Dim LastRow As Long

 'duplicate source sheet
    On Error Resume Next
    wb.Sheets("PeteDTempData").Delete
    wb.Sheets(wsn).Copy After:=wb.Sheets(wsn)
    wb.ActiveSheet.Name = "PeteDTempData"
    Set TempSheet = wb.Sheets("PeteDTempData")

 'sort
    TempSheet.UsedRange.AutoFilter
    LastRow = TempSheet.Cells(Rows.Count, c).End(xlUp).Row
    TempSheet.Sort.SortFields.Add Key:=Range(Cells(2, c), Cells(LastRow, c)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

    With TempSheet.Sort
        .SetRange Range(Cells(1, c), Cells(LastRow, c))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'number range
    Dim j As Long
    Dim i As Long
    Dim CountCol As Long

    CountCol = TempSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1

    j = 1
    For i = 2 To LastRow
        TempSheet.Cells(i, CountCol) = j
    j = j + 1
    Next i

'find first MyCrit
    FirstCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole).Row

'calculate rank
    With TempSheet
        MyRank = FirstCritRow - 1
    End With

'delete temp sheet
    TempSheet.Delete
    Ws.Select

End Sub

Sub BottomTenItemSub()

'set sheets
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim TempSheet As Worksheet
    Set Ws = wb.Sheets(wsn)
    Dim LastRow As Long

 'duplicate source sheet
    On Error Resume Next
    wb.Sheets("PeteDTempData").Delete
    wb.Sheets(wsn).Copy After:=wb.Sheets(wsn)
    wb.ActiveSheet.Name = "PeteDTempData"
    Set TempSheet = wb.Sheets("PeteDTempData")

 'sort
    TempSheet.UsedRange.AutoFilter
    LastRow = TempSheet.Cells(Rows.Count, c).End(xlUp).Row
    TempSheet.Sort.SortFields.Add Key:=Range(Cells(2, c), Cells(LastRow, c)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

    With TempSheet.Sort
        .SetRange Range(Cells(1, c), Cells(LastRow, c))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'number range
    Dim j As Long
    Dim i As Long
    Dim CountCol As Long

    CountCol = TempSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1

    j = 1
    For i = 2 To LastRow
        TempSheet.Cells(i, CountCol) = j
    j = j + 1
    Next i

'find first MyCrit
    FirstCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole).Row

'calculate rank
    With TempSheet
        MyRank = (LastRow - FirstCritRow) + 1
    End With

'delete temp sheet
    TempSheet.Delete
    Ws.Select

End Sub

Sub TopTenPercSub()

'set sheets
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim TempSheet As Worksheet
    Set Ws = wb.Sheets(wsn)
    Dim LastRow As Long

 'duplicate source sheet
    On Error Resume Next
    wb.Sheets("PeteDTempData").Delete
    wb.Sheets(wsn).Copy After:=wb.Sheets(wsn)
    wb.ActiveSheet.Name = "PeteDTempData"
    Set TempSheet = wb.Sheets("PeteDTempData")

 'sort
    TempSheet.UsedRange.AutoFilter
    LastRow = TempSheet.Cells(Rows.Count, c).End(xlUp).Row
    TempSheet.Sort.SortFields.Add Key:=Range(Cells(2, c), Cells(LastRow, c)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

    With TempSheet.Sort
        .SetRange Range(Cells(1, c), Cells(LastRow, c))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'number range
    Dim j As Long
    Dim i As Long
    Dim CountCol As Long

    CountCol = TempSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1

    j = 1
    For i = 2 To LastRow
        TempSheet.Cells(i, CountCol) = j
    j = j + 1
    Next i

'find first MyCrit
    FirstCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole).Row

'find last MyCrit
    LastCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole, SearchDirection:=xlPrevious).Row

'find middle MyCrit
    MiddleCritRow = WorksheetFunction.Average(FirstCritRow, LastCritRow)
        MiddleCritRow = Round(MiddleCritRow, 0)

'calculate percent
    With TempSheet
        MyRank = .Cells(MiddleCritRow, CountCol) / (LastRow - 1)
            MyRank = MyRank * 100
                MyRank = Round(MyRank, 0)
    End With

'delete temp sheet
    TempSheet.Delete
    Ws.Select

End Sub

Sub BottomTenPercSub()

'set sheets
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim TempSheet As Worksheet
    Set Ws = wb.Sheets(wsn)
    Dim LastRow As Long

 'duplicate source sheet
    On Error Resume Next
    wb.Sheets("PeteDTempData").Delete
    wb.Sheets(wsn).Copy After:=wb.Sheets(wsn)
    wb.ActiveSheet.Name = "PeteDTempData"
    Set TempSheet = wb.Sheets("PeteDTempData")

 'sort
    TempSheet.UsedRange.AutoFilter
    LastRow = TempSheet.Cells(Rows.Count, c).End(xlUp).Row
    TempSheet.Sort.SortFields.Add Key:=Range(Cells(2, c), Cells(LastRow, c)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

    With TempSheet.Sort
        .SetRange Range(Cells(1, c), Cells(LastRow, c))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'number range
    Dim j As Long
    Dim i As Long
    Dim CountCol As Long

    CountCol = TempSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1

    j = 1
    For i = 2 To LastRow
        TempSheet.Cells(i, CountCol) = j
    j = j + 1
    Next i

'find first MyCrit
    FirstCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole).Row

'find last MyCrit
    LastCritRow = TempSheet.Columns(c).Find(What:=MyCrit, LookAt:=xlWhole, SearchDirection:=xlPrevious).Row

'find middle MyCrit
    MiddleCritRow = WorksheetFunction.Average(FirstCritRow, LastCritRow)
        MiddleCritRow = Round(MiddleCritRow, 0)

'calculate percent
    With TempSheet
        MyRank = .Cells(MiddleCritRow, CountCol) / (LastRow - 1)
            MyRank = 1 - MyRank
                MyRank = MyRank * 100
                    MyRank = Round(MyRank, 0)
    End With

'delete temp sheet
    TempSheet.Delete
    Ws.Select

End Sub

Sub DynamicSub()

    Select Case MyCrit
        Case 33: s = "xlFilterAboveAverage"           'Filter all above-average values.
        Case 24: s = "xlFilterAllDatesInPeriodApril"  'Filter all dates in April.
        Case 28: s = "xlFilterAllDatesInPeriodAugust"    'Filter all dates in August.
        Case 32: s = "xlFilterAllDatesInPeriodDecember"    'Filter all dates in December.
        Case 22: s = "xlFilterAllDatesInPeriodFebruray"    'Filter all dates in February.
        Case 21: s = "xlFilterAllDatesInPeriodJanuary"    'Filter all dates in January.
        Case 27: s = "xlFilterAllDatesInPeriodJuly"   'Filter all dates in July.
        Case 26: s = "xlFilterAllDatesInPeriodJune"   'Filter all dates in June.
        Case 23: s = "xlFilterAllDatesInPeriodMarch"  'Filter all dates in March.
        Case 25: s = "xlFilterAllDatesInPeriodMay"    'Filter all dates in May.
        Case 31: s = "xlFilterAllDatesInPeriodNovember"    'Filter all dates in November.
        Case 30: s = "xlFilterAllDatesInPeriodOctober"    'Filter all dates in October.
        Case 17: s = "xlFilterAllDatesInPeriodQuarter1"    'Filter all dates in Quarter1.
        Case 18: s = "xlFilterAllDatesInPeriodQuarter2"    'Filter all dates in Quarter2.
        Case 19: s = "xlFilterAllDatesInPeriodQuarter3"    'Filter all dates in Quarter3.
        Case 20: s = "xlFilterAllDatesInPeriodQuarter4"    'Filter all dates in Quarter4.
        Case 29: s = "xlFilterAllDatesInPeriodSeptember"    'Filter all dates in September.
        Case 34: s = "xlFilterBelowAverage"           'Filter all below-average values.
        Case 8: s = "xlFilterLastMonth"               'Filter all values related to last month.
        Case 11: s = "xlFilterLastQuarter"            'Filter all values related to last quarter.
        Case 5: s = "xlFilterLastWeek"                'Filter all values related to last week.
        Case 14: s = "xlFilterLastYear"               'Filter all values related to last year.
        Case 9: s = "xlFilterNextMonth"               'Filter all values related to next month.
        Case 12: s = "xlFilterNextQuarter"            'Filter all values related to next quarter.
        Case 6: s = "xlFilterNextWeek"                'Filter all values related to next week.
        Case 15: s = "xlFilterNextYear"               'Filter all values related to next year.
        Case 7: s = "xlFilterThisMonth"               'Filter all values related to the current month.
        Case 10: s = "xlFilterThisQuarter"            'Filter all values related to the current quarter.
        Case 4: s = "xlFilterThisWeek"                'Filter all values related to the current week.
        Case 13: s = "xlFilterThisYear"               'Filter all values related to the current year.
        Case 1: s = "xlFilterToday"                   'Filter all values related to the current date.
        Case 3: s = "xlFilterTomorrow"                'Filter all values related to tomorrow.
        Case 16: s = "xlFilterYearToDate"             'Filter all values from today until a year ago.
        Case 2: s = "xlFilterYesterday"               'Filter all values related to yesterday.
    End Select

End Sub
Improve this answer
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.