Solved

VBA to determine criteria of AutoFilter

Posted on 2016-09-02
12
57 Views
Last Modified: 2016-09-09
I have a Project Cost reporting Excel file in use by a number of Project Managers.

A feature which I have installed on these files is an option to add additional rows of data at the click of a button rather than inserting them manually. Doing it by VBA ensures that all of the various calculations in each row are correctly copied into the new rows.

This works fine until one of the PMs reported an issue today. If an AutoFilter has been applied and thereby hiding rows the script throws an error.

I have built a workaround with a Warning message and basically fill the visible cells of a blank column with ###, show all data, run the insert code, reapply the filter on the ### column and then delete the ### entries, thus restoring the visible appearance of the filtered data.

The relevant lines of the code are shown below.

I have just showed this to a colleague and he pointed out that the filter is now on column A, the little funnel symbol on the AutoFilter dropdown shows it. Do we know what was filtered before?

So, my question is, can we determine the Filter Criteria in VBA? I can scan across and look for the Funnel symbol and check the criteria manually but can that be done automagically?

Although the filter is applied from columns A to CN, I suspect the Filter Criteria will be in columns B to X as these are the columns that the PM will be dealing with; the remaining columns are cost profiling calculations.

If there isn't a "simple" solution, I will stick with what I have and will allow for it in the Guidance Notes which I am also compiling.

Many thanks
Rob H

    CR = ActiveCell.Row
    CC = ActiveCell.Column
    LR = Range("LastRow").Row
    Range("A16:A" & LR).Select
    FullCount = Selection.Cells.Count
    VisCount = Selection.SpecialCells(xlVisible).Count
    Cells(CR, CC).Select
    If FullCount <> VisCount Then
        Check = MsgBox("There is a Filter in place. Please double check position of cursor." & Chr(10) _
                    & "Rows will be inserted above current position." & Chr(10) _
                    & "Filter will be re-applied after rows are inserted.", vbOKCancel, "Filter Check")
        If Check = vbCancel Then Exit Sub
    End If

.....Code to Insert Rows....

    LR = Range("LastRow").Row
    ActiveSheet.Range("$A$15:$CN$" & LR).AutoFilter Field:=1, Criteria1:="###"
    Range("A16:A" & LR).ClearContents

Open in new window

0
Comment
Question by:Rob Henson
  • 6
  • 4
  • 2
12 Comments
 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
Rob,

good to see that you asked a question. as most of the time, i see you answering the questions :)

so on your question
So, my question is, can we determine the Filter Criteria in VBA? I can scan across and look for the Funnel symbol and check the criteria manually but can that be done automagically?

please see attached UDF.  the UDF returns the filter criteria for Filter.  if it returns  {*} means no filter in that column.  

also please note that VBA cannot return the filter criteria for Dates that is a bug and Microsoft is aware of it.
EE.xlsm
0
 
LVL 31

Author Comment

by:Rob Henson
Comment Utility
Hi Prof, only on phone now. Might get chance to look at file over the weekend otherwise it will be on Monday.

Thanks
Rob
0
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
A feature which I have installed on these files is an option to add additional rows of data at the click of a button rather than inserting them manually. Doing it by VBA ensures that all of the various calculations in each row are correctly copied into the new rows.

Data formatted as a Table will do this without VBA. You can also set this up in Excel Options if you don't want to use a Table
0
 
LVL 31

Author Comment

by:Rob Henson
Comment Utility
Hi Roy,

Unfortunately, a table wouldn't work as the blocks of data with the formulae are contiguous.

Thanks
Rob
0
 
LVL 31

Author Comment

by:Rob Henson
Comment Utility
HI Prof,

Didn't get chance over the weekend, no surprise, but now can't download an xlsm at work. Can you copy into a text file and upload that instead? I can then copy into a module to test the UDF.

Thanks
Rob
0
 
LVL 31

Author Comment

by:Rob Henson
Comment Utility
@Roy - oops, missed an important word from my comment for you, they are NOT contiguous.
0
Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
hi Rob,

here is the UDF

Function FilterCriteria(Rng As Range) As String
 Application.Volatile
Dim Filter As String

Filter = "{"
On Error GoTo Finish
With Rng.Parent.AutoFilter

If Intersect(Rng, .Range) Is Nothing Then GoTo Finish
With .Filters(Rng.Column - .Range.Column + 1)
If Not .On Then GoTo Finish
FilterString = .Criteria1

If IsArray(FilterString) Then

FilterUpper = UBound(FilterString)
FilterLower = LBound(FilterString)
If FilterString(FilterUpper) = "=" Then FilterUpper = FilterUpper - 1
For i = FilterLower To FilterUpper
Filter = Filter + Replace(FilterString(i), "=", "")
If i < FilterUpper Then Filter = Filter + ","
Next
Else

On Error GoTo missing
If IsMissing(.Criteria2) Then

missing: If .Criteria1 <> "=" Then
Filter = Filter + Replace(.Criteria1, "=", "")
End If
Else

Filter = Filter + Replace(.Criteria1, "=", "")
If .Criteria2 <> "=" Then
Filter = Filter + "," + Replace(.Criteria2, "=", "")
End If
End If
End If
End With
End With
Finish:

If Len(Filter) = 1 Then
Filter = Filter + "*"
End If

FilterCriteria = Filter + "}"
End Function

Open in new window

0
 
LVL 31

Author Comment

by:Rob Henson
Comment Utility
Hi ProfJJ,

Thanks for the update. I am not convinced I am going to be able to use this but I could be persuaded.

Does this work for dates? Some of the columns that might have a filter applied contain dates, eg Task Start and Finish Dates, Invoice Date etc. The filter might be applied to show tasks that are within the current year. When I apply the UDF to a Date column and then filter on that column it gives a number, for example filtering for "This Year" gives {13}.

Can I convert it to part of the main macro removing and re-applying the filter? I am thinking I could use an EVALUATE statement for each column in the range where I believe the filter will be used, capturing each result into an array; either with a column identifier or an array value for each column with the {*} for those where no filter is applied. How do I then use the Array to re-apply the filter?

Thanks
Rob H

EDIT: Just seen original comment about dates.
0
 
LVL 17

Expert Comment

by:Roy_Cox
Comment Utility
Hi Rob

You had mean wondering!
0
 
LVL 25

Accepted Solution

by:
ProfessorJimJam earned 500 total points
Comment Utility
Hi Rob,

there is no way to get the dates details of auto-filter. simply put it is impossible until now.

i do not believe you can get any better code than the below one. it will list all filter details in new sheet.

original author of this code is my friend and MVP fellow Zack Barresse

Option Explicit


Private Const Delimiter As String = "|"
Private Const TargetSheetName As String = "Filter Report"


Sub ListWorkbookFilters()

    Dim Sheet As Worksheet
    Dim Target As Worksheet
    Dim SheetFilter As Collection
    Dim SheetFilters As Collection
    Dim Table As ListObject
    Dim Filters() As Variant
    Dim ColumnIndex As Long
    Dim FilterIndex As Long
    Dim FilterCount As Long
    Dim SheetHasFilter As Boolean
    Dim TableHasFilter As Boolean

    ' Set initial variables
    Set SheetFilter = New Collection
    Set SheetFilters = New Collection
    ReDim Filters(1 To 7, 1 To 1)

    ' Loop through all sheets in workbook
    For Each Sheet In ThisWorkbook.Worksheets

        SheetHasFilter = False
        If Sheet.FilterMode Then
            If Sheet.AutoFilter.Filters.Count > 0 Then

                ' Create a new filter collection, loop through all sheet filters
                Set SheetFilter = New Collection
                For FilterIndex = 1 To Sheet.AutoFilter.Filters.Count

                    ' If filter is on, add to array
                    If Sheet.AutoFilter.Filters(FilterIndex).On Then

                        ' Redimension array to fit new data
                        FilterCount = FilterCount + 1
                        ReDim Preserve Filters(1 To 7, 1 To FilterCount)

                        ' Add data to array
                        Filters(1, FilterCount) = Sheet.Name
                        Filters(2, FilterCount) = Sheet.AutoFilter.Range.Address(0, 0)
                        Filters(3, FilterCount) = FilterIndex
                        
                        On Error Resume Next
                        If IsArray(Sheet.AutoFilter.Filters(FilterIndex).Criteria1) Then
                            Filters(4, FilterCount) = CriteriaString(Sheet.AutoFilter.Filters(FilterIndex).Criteria1, Delimiter)
                        Else
                            Filters(4, FilterCount) = Sheet.AutoFilter.Filters(FilterIndex).Criteria1
                        End If
                        If IsEmpty(Filters(4, FilterCount)) Then Filters(4, FilterCount) = "Unable to obtain"
                        Filters(5, FilterCount) = Sheet.AutoFilter.Filters(FilterIndex).Criteria2
                        On Error GoTo 0
                        
                        Filters(6, FilterCount) = OperatorName(Sheet.AutoFilter.Filters(FilterIndex).Operator)
                        Filters(7, FilterCount) = "Worksheet"

                        ' Add array to colleciton
                        SheetFilter.Add Filters(), Sheet.Name & ":" & FilterIndex
                        SheetHasFilter = True

                    End If
                Next FilterIndex
            End If
        End If

        ' Loop through all tables on sheet
        For Each Table In Sheet.ListObjects
            TableHasFilter = False
            If Table.AutoFilter.FilterMode And Table.AutoFilter.Filters.Count > 0 Then
                For ColumnIndex = 1 To Table.ListColumns.Count

                    ' If filter is on, add to array
                    If Table.AutoFilter.Filters(ColumnIndex).On Then

                        ' Redimension array to fit new data
                        FilterCount = FilterCount + 1
                        ReDim Preserve Filters(1 To 7, 1 To FilterCount)

                        ' Add data to array
                        Filters(1, FilterCount) = Sheet.Name
                        Filters(2, FilterCount) = Table.Range.Address(0, 0)
                        Filters(3, FilterCount) = ColumnIndex
                        If IsArray(Table.AutoFilter.Filters(ColumnIndex).Criteria1) Then
                            Filters(4, FilterCount) = CriteriaString(Table.AutoFilter.Filters(ColumnIndex).Criteria1, Delimiter)
                        Else
                            Filters(4, FilterCount) = Table.AutoFilter.Filters(ColumnIndex).Criteria1
                        End If
                        On Error Resume Next
                        Filters(5, FilterCount) = Table.AutoFilter.Filters(ColumnIndex).Criteria2
                        On Error GoTo 0
                        Filters(6, FilterCount) = OperatorName(Table.AutoFilter.Filters(ColumnIndex).Operator)
                        Filters(7, FilterCount) = "Table"
                        TableHasFilter = True
                    End If
                Next ColumnIndex

                ' Add array to colleciton
                If TableHasFilter Then
                    SheetFilter.Add Filters(), CStr(Table.DisplayName)
                End If

            End If
        Next Table

        ' Add array to colleciton
        If SheetHasFilter Then SheetFilters.Add SheetFilter, Sheet.Name
        If TableHasFilter Then SheetFilters.Add SheetFilter, Sheet.Name & " Tables"

    Next Sheet

    ' Set report sheet, even if it exists
    If WorksheetExists(TargetSheetName, ThisWorkbook) Then
        Set Target = ThisWorkbook.Worksheets(TargetSheetName)
        Target.Cells.Clear
    Else
        Set Target = ThisWorkbook.Worksheets.Add
        Target.Name = TargetSheetName
    End If

    ' Output headers and filter values
    If FilterCount > 0 Then
        Target.Cells(1, 1).Resize(1, UBound(Filters, 1) - LBound(Filters, 1) + 1).Value = Array("Sheet", "Range", "Field", "Criteria1", "Criteria2", "Operator", "Object")
        For FilterIndex = LBound(Filters, 2) To UBound(Filters, 2)
            Target.Cells(FilterIndex + 1, 1).Value = Filters(1, FilterIndex)
            Target.Cells(FilterIndex + 1, 2).Value = Filters(2, FilterIndex)
            Target.Cells(FilterIndex + 1, 3).Value = Filters(3, FilterIndex)
            Target.Cells(FilterIndex + 1, 4).Value = "'" & Filters(4, FilterIndex)
            Target.Cells(FilterIndex + 1, 5).Value = "'" & Filters(5, FilterIndex)
            Target.Cells(FilterIndex + 1, 6).Value = Filters(6, FilterIndex)
            Target.Cells(FilterIndex + 1, 7).Value = Filters(7, FilterIndex)
        Next FilterIndex
        Target.Cells.EntireColumn.AutoFit
    Else
        MsgBox "No filters were found.", vbExclamation, "ThisWorkbook Filters"
    End If

End Sub


Function CriteriaString(ByVal Criteria As Variant, Optional ByVal Delimiter As String = "|") As String
'
' Return a delimited string of an array of items. If not an array, return the item
'
    Dim CriteriaIndex As Long
    Dim CriteriaTemp As String

    If IsArray(Criteria) = False Then
        On Error Resume Next
        CriteriaString = CStr(Criteria)
        On Error GoTo 0
        Exit Function
    End If

    For CriteriaIndex = LBound(Criteria) To UBound(Criteria)
        On Error Resume Next
        CriteriaTemp = CriteriaTemp & CStr(Criteria(CriteriaIndex)) & Delimiter
        On Error GoTo 0
    Next CriteriaIndex

    If Len(CriteriaTemp) > 0 Then
        On Error Resume Next
        CriteriaString = CStr(Left(CriteriaTemp, Len(CriteriaTemp) - Len(Delimiter)))
        On Error GoTo 0
    End If

End Function


Function WorksheetExists( _
         ByVal SheetName As String, _
         Optional TargetBook As Workbook _
         ) As Boolean
'
' Returns True if the specified worksheet is found in the specified workbook.
'
' Syntax:       WorksheetExists(SheetName,[TargetBook])
'
' Parameters:   SheetName. String. Required. The name of the worksheet to test existence.
'               TargetBook. Workbok. Optional. Specify the workbook to look in. If omitted
'                   the active workbook will be used.
'
    If TargetBook Is Nothing Then
        If ActiveWorkbook Is Nothing Then Exit Function
        Set TargetBook = ActiveWorkbook
    End If
    On Error Resume Next
    WorksheetExists = CBool(Len(TargetBook.Worksheets(SheetName).Name) <> 0)
    On Error GoTo 0

End Function



Public Function OperatorName(ByVal Operator As XlAutoFilterOperator) As String
'
' Return the text equivalent of the Operator enumeration value.
'
    Dim OperatorNumber As Long

    OperatorNumber = CLng(Operator)

    Select Case OperatorNumber
    Case 0: OperatorName = "Less than or Greater than/Equal to"
    Case 1: OperatorName = "xlAnd"
    Case 2: OperatorName = "xlOr"
    Case 3: OperatorName = "xlTop10Items"
    Case 4: OperatorName = "xlBottom10Items"
    Case 5: OperatorName = "xlTop10Percent"
    Case 6: OperatorName = "xlBottom10Percent"
    Case 7: OperatorName = "xlFilterValues"
    Case 8: OperatorName = "xlFilterCellColor"
    Case 9: OperatorName = "xlFilterFontColor"
    Case 10: OperatorName = "xlFilterIcon"
    Case 11: OperatorName = "xlFilterDynamic"
    Case 12: OperatorName = "xlFilterNoFill"
    Case 13: OperatorName = "xlFilterAutomaticFontColor"
    Case 14: OperatorName = "xlFilterNoIcon"
    End Select

End Function

Open in new window

0
 
LVL 31

Author Closing Comment

by:Rob Henson
Comment Utility
Hi ProfJJ,

Thanks for the help with this, much appreciated.

Cheers
Rob
0
 
LVL 25

Expert Comment

by:ProfessorJimJam
Comment Utility
you are welcome Rob.

cheers,
ProfJJ
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now