Private Sub Worksheet_Calculate()
     ' для срабатывания добавить промитоги, или летучую функцию (сегодня, ...)
     Call Мяу
End Sub
Sub Мяу()
    Dim arr, i&, k&, r As Range
    If AutoFilterMode Then
        With ActiveSheet.AutoFilter
            k = .Range(1).Column
            .Range.FormatConditions.Delete
            For i = 1 To .Range.Columns.Count
                If .Filters(i).On Then
                    ' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                    ' выделяется весь столбец
                    ' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                    ' Set r = Intersect(.Range, ActiveSheet.Columns(i + k - 1))
                    ' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                    ' выделяется 1 ячейка в шапке
                    Set r = Intersect(.Range.Rows(1), ActiveSheet.Columns(i + k - 1))
                    ' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                    r.FormatConditions.Add Type:=xlExpression, Formula1:="=СТОЛБЕЦ()=" & i + k - 1
                    r.FormatConditions(1).Interior.Color = 255
                    Set r = Nothing
                End If
            Next
        End With
    End If
End Sub