Can you change colour of column header with VBA on Filter selection?

[brendanolear]

I want users of a spreadsheet to easily identify columns they have already applied filters to. I know the tiny filter box changes; however some users struggle to see where they have already applied filters and I am trying to make their lives a bit easier.

Any help appreciated.

 

[Sektor]

Activate sheet with autofilter and execute this macro:

Sub ShowFilterInfo()

    Dim af As AutoFilter
    Dim f As Filter
    Dim sCols As String
    Dim c As Integer
    
    If Not ActiveSheet.AutoFilterMode Then
        MsgBox "AutoFilter does not exist in this sheet"
        Exit Sub
    End If


    Set af = ActiveSheet.AutoFilter
    For Each f In af.Filters
        c = c + 1
        If f.On Then
            sCols = sCols & c & ", "
        End If
    Next
    
    If Len(sCols) > 0 Then
        MsgBox "Filters are applied in the following columns: " & Chr(13) & Left$(sCols, Len(sCols) - 2)
    Else
        MsgBox "No filters applied found."
    End If


End Sub

 

[Sektor]

Well, the code I wrote gives a bit wrong information. First, it gives column as number and not as text. Second, the column index is relative to autofilter - not the beginning of sheet (i.e. A1 cell). If autofilter happens to begin at, say, F1, then the column index would not be the one expected. Here's correct code which gives correct column as text.

Sub ShowFilterInfo()


    Dim af As AutoFilter
    Dim f As Filter
    Dim sCols As String
    Dim c As Integer, iCol As Integer
    Dim firstCell As Integer
    Dim re As Object
    
    If Not ActiveSheet.AutoFilterMode Then
        MsgBox "AutoFilter does not exit in this sheet"
        Exit Sub
    End If


    Set af = ActiveSheet.AutoFilter
    firstCell = af.Range(1).Column
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[A-Z]+"
    
    For Each f In af.Filters
        c = c + 1
        If f.On Then
            iCol = c + firstCell - 1
            sCols = sCols & re.Execute(Cells(1, iCol).Address)(0) & ", "
        End If
    Next


    If Len(sCols) > 0 Then
        MsgBox "Filters are applied in the following columns: " & Chr(13) & Left$(sCols, Len(sCols) - 2)
    Else
        MsgBox "No filters applied found."
    End If
    
    Set re = Nothing


End Sub