ExcelBanter - Conditionally format header when column is filtered

This macro [ShowMsgbox] lists all the filters in your active workbook.
I'm on the run and can't customize it for you but this should give you the
basis to highlihgting the headers.

--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown

Option Explicit

'/============================================/
Sub Filters_ShowMsgbox()
'show messagebox with filters applied to database
Dim filterArray()
Dim f As Long
Dim i As Long
Dim xCounter As Long
Dim currentFiltRange As String, strAnswer As String
Dim strAnswerTitle As String
Dim varPrinters As Variant
Dim strAndIf As String
Dim w As Worksheet

're-set classes that have lost scope
' This call is in all 'Favorites'
Call Class_Reinitialization

'check for an active workbook
If ActiveWorkbook Is Nothing Then
'no workbooks open, so create one
Workbooks.Add
End If

xCounter = 0
Set w = ActiveSheet

'check if autofilter is on
If w.AutoFilterMode = False Then
MsgBox "There is no AutoFilter in this worksheet.", _
vbCritical + vbOKOnly, "Warning..."
Set w = Nothing
Exit Sub
End If

strAnswerTitle = "Filters in Worksheet..."
With w.AutoFilter
currentFiltRange = .Range.Address
i = .Range.Column - 1

strAnswer = "Worksheet/Range: " & w.name & _
"!" & currentFiltRange & vbCr
With .Filters
ReDim filterArray(1 To .Count, 1 To 3)
For f = 1 To .Count
With .item(f)
If .On Then
xCounter = 1
filterArray(f, 1) = .Criteria1
strAnswer = strAnswer & _
WorksheetFunction.Rept(" ", 31) & _
"Col: ( " & _
ColumnLetterFromNumber(f + i) & " ) " _
& .Criteria1
If .Operator Then
filterArray(f, 2) = .Operator
filterArray(f, 3) = .Criteria2

If .Operator = xlAnd Then
strAndIf = " and "
Else
strAndIf = " or "
End If

strAnswer = _
strAnswer & strAndIf & .Criteria2

End If
strAnswer = strAnswer & vbCr
End If
End With
Next f
End With
End With

If xCounter = 0 Then
strAnswer = strAnswer & vbCr & _
"The filter is set to 'Show All'"
End If

MsgBox strAnswer, vbOKOnly, strAnswerTitle

exit_Sub:
Set w = Nothing

End Sub
'/============================================/
Sub Filters()
'show filters applied to database
'ask if user wants msgbox or info put on worksheet
Dim filterArray()
Dim f As Long
Dim i As Long, x As Long
Dim xCounter As Long
Dim currentFiltRange As String, strAnswer As String
Dim strAnswer0 As String, strAnswer1 As String
Dim strAnswer2 As String, strAnswer3 As String
Dim strAnswerTitle As String
Dim strAndIf As String
Dim w As Worksheet

xCounter = 0
Set w = ActiveSheet

'check if autofilter is on
If w.AutoFilterMode = False Then
MsgBox "There is no AutoFilter in this worksheet.", _
vbCritical + vbOKOnly, "Warning..."
Set w = Nothing
Exit Sub
End If

strAnswerTitle = "Filters in Worksheet..."
strAnswer1 = "Show List in Message Box"
strAnswer2 = "Put List on Worksheet at current location"
strAnswer3 = "Cancel"

strAnswer0 = Wksht_or_Msgbox(strAnswerTitle, strAnswer1, _
strAnswer2, strAnswer3)

If strAnswer0 = strAnswer3 Then
GoTo exit_Sub
End If

Select Case strAnswer0
Case strAnswer1
With w.AutoFilter
currentFiltRange = .Range.Address
i = .Range.Column - 1

strAnswer = "Worksheet/Range: " & w.name & "!" & _
currentFiltRange & vbCr
With .Filters
ReDim filterArray(1 To .Count, 1 To 3)
For f = 1 To .Count
With .item(f)
If .On Then
xCounter = 1
filterArray(f, 1) = .Criteria1
strAnswer = strAnswer & _
WorksheetFunction.Rept(" ", 31) & _
"Col: ( " & _
ColumnLetterFromNumber(f + i) & " ) " & _
.Criteria1
If .Operator Then
filterArray(f, 2) = .Operator
filterArray(f, 3) = .Criteria2

If .Operator = xlAnd Then
strAndIf = " and "
Else
strAndIf = " or "
End If

strAnswer = _
strAnswer & strAndIf & .Criteria2

End If
strAnswer = strAnswer & vbCr
End If
End With
Next
End With
End With
If xCounter = 0 Then
strAnswer = strAnswer & vbCr & _
"The filter is set to 'Show All'"
End If
MsgBox strAnswer, vbOKOnly, strAnswerTitle

Case strAnswer2
With w.AutoFilter
currentFiltRange = .Range.Address
i = .Range.Column - 1
ActiveCell.value = _
"Worksheet/Range: " & w.name & "!" & _
currentFiltRange
With .Filters
ReDim filterArray(1 To .Count, 1 To 3)
For f = 1 To .Count
With .item(f)
If .On Then
xCounter = 1
x = x + 1
filterArray(f, 1) = .Criteria1
strAnswer = strAnswer & _
WorksheetFunction.Rept(" ", 2) & _
"Col: ( " & _
ColumnLetterFromNumber(f + i) & " ) " & _
.Criteria1
If .Operator Then
filterArray(f, 2) = .Operator
filterArray(f, 3) = .Criteria2

If .Operator = xlAnd Then
strAndIf = " and "
Else
strAndIf = " or "
End If

strAnswer = _
strAnswer & strAndIf & .Criteria2

End If
ActiveCell.Offset(x, 0).value = strAnswer
strAnswer = ""
End If
End With
Next
End With
End With
If xCounter = 0 Then
ActiveCell.value = "The filter is set to 'Show All'"
End If

Case strAnswer3
GoTo exit_Sub
Case Else
GoTo exit_Sub
End Select

exit_Sub:
Set w = Nothing

End Sub
'/============================================/
Function Wksht_or_Msgbox(strTitle, str1, str2, str3) _
As String
'Adds choices as defined in Ops array below
Dim aryChoices()
Dim iMaxChoices As Double
Dim varChoiceSelected As Variant

iMaxChoices = 3
ReDim aryChoices(1 To iMaxChoices)

aryChoices(1) = str1
aryChoices(2) = str2
aryChoices(3) = str3

'Array of choices, default choice, title of form
varChoiceSelected = GetChoice(aryChoices, 1, _
strTitle)
' MsgBox aryChoices(varChoiceSelected)
Wksht_or_Msgbox = aryChoices(varChoiceSelected)
End Function
'/============================================/