Solved

VBA to determine criteria of AutoFilter

Posted on 2016-09-02
12
122 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 26

Expert Comment

by:ProfessorJimJam
ID: 41781804
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 33

Author Comment

by:Rob Henson
ID: 41781823
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 18

Expert Comment

by:Roy_Cox
ID: 41782010
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
Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
LVL 33

Author Comment

by:Rob Henson
ID: 41784370
Hi Roy,

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

Thanks
Rob
0
 
LVL 33

Author Comment

by:Rob Henson
ID: 41784372
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 33

Author Comment

by:Rob Henson
ID: 41784373
@Roy - oops, missed an important word from my comment for you, they are NOT contiguous.
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41784576
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 33

Author Comment

by:Rob Henson
ID: 41784839
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 18

Expert Comment

by:Roy_Cox
ID: 41784979
Hi Rob

You had mean wondering!
0
 
LVL 26

Accepted Solution

by:
ProfessorJimJam earned 500 total points
ID: 41786500
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 33

Author Closing Comment

by:Rob Henson
ID: 41791056
Hi ProfJJ,

Thanks for the help with this, much appreciated.

Cheers
Rob
0
 
LVL 26

Expert Comment

by:ProfessorJimJam
ID: 41791062
you are welcome Rob.

cheers,
ProfJJ
0

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

828 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