Lodbrok.be
Function DispCriteria(Rng As Range) As String
' Display Filter Criteria
' parameter: Range, select applicable column for dynamic update
' sample: =DispCriteria(J:J)
' result: ">50" or "=TRUE" (good for booleans or small number filters)
' issue: criteria are not always picked-up completely
' note:
'if you just want a count of filtered items you can better use a formula
'sample: =COUNTA(I$2:I$22)-SUBTOTAL(103,I$2:I$22)
Dim Filter As String
Filter = ""
On Error GoTo Done
With Rng.Parent.AutoFilter
If Intersect(Rng, .Range) Is Nothing Then GoTo Done
With .Filters(Rng.Column - .Range.Column + 1)
If Not .On Then GoTo Done
Filter = .Criteria1
'criteria may be empty
Select Case .Operator
Case xlAnd
Filter = Filter & " AND " & .Criteria2
Case xlOr
Filter = Filter & " OR " & .Criteria2
End Select
End With
End With
Done:
'criteria are not always picked-up completely
If Filter = "" Then
Filter = "?"
End If
DispCriteria = Filter
End Function
Function GetColumns(Rng As Range) As String
' Get Column letters having a filter, else return "*"
' parameter: Range, select first filtered column for dynamic update
' sample: =GetColumns(A:A)
' result: ,E,H,J,AA (=4 columns have filters)
Dim Sht As Worksheet
Dim i As Long
Dim FList As String
Dim ColumnNumber As Long
Dim ColumnLetter As String
FList = ""
Set Sht = ActiveSheet
With Sht.AutoFilter
For i = 1 To .Filters.Count
If .Filters(i).On Then
ColumnNumber = .Range(1, i).Column
ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
FList = FList & "," & ColumnLetter
End If
Next i
End With
If FList = "" Then
FList = "*"
End If
GetColumns = FList
End Function
Function IsFiltered(Rng As Range) As String
' if column Is Filtered return "!", else "*"
' parameter: Range, select applicable column for dynamic update
' advantage: can also be used in conditional format using formula...
' sample: =IsFiltered(C:C)="!"
Dim Filter As String
Filter = ""
On Error GoTo Done
With Rng.Parent.AutoFilter
If Intersect(Rng, .Range) Is Nothing Then GoTo Done
With .Filters(Rng.Column - .Range.Column + 1)
If Not .On Then GoTo Done
Filter = "!"
End With
End With
Done:
If Filter = "" Then
Filter = "*"
End If
IsFiltered = Filter
End Function
Sub HighLightFilterTitle()
Dim xRg As Range
Dim xPos As Range
Dim I As Integer
Dim xCount As Long
Dim xRgCol As Long
Dim xAddress As String
Dim xFilterCount As Long
On Error Resume Next
'remember original position
Set xPos = ActiveCell
xAddress = ActiveWindow.RangeSelection.Address
'MsgBox ("select filter row")
'Set xRg = Application.InputBox("Please select the first cell of the table range:", "KuTools For Excel", xAddress, , , , , 8)
' assuming the filter is on row 1, going to pos a1 to have the full row
Set xRg = Range("A1")
'Set xRg = ActiveCell
'Set xRg = Cells(ActiveCell.Row, 1)
'do nothing if there is no autofilter
If xRg.Parent.AutoFilter Is Nothing Then
MsgBox ("No autofilter found!" & Chr(13) & "If you use a table with filter, a cell in the table may need to be selected.")
Exit Sub
End If
' assuming the filter is on row 1
Rows("1:1").Select
'ActiveCell.Rows.Select
'ActiveCell.EntireRow.Select
' remove all filter highlights
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
' Selection.Borders(xlEdgeLeft).LineStyle = xlNone
' Selection.Borders(xlEdgeTop).LineStyle = xlNone
' Selection.Borders(xlEdgeRight).LineStyle = xlNone
' Selection.Borders(xlInsideVertical).LineStyle = xlNone
' Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
If xRg Is Nothing Then Exit Sub
xRg.Select
With xRg(1).Parent.AutoFilter
xFilterCount = .Range.Columns.Count
xRgCol = xRg.Offset(1).Column - .Range.Column + 1
For I = xRgCol To xFilterCount
xCount = xRg.Offset(, I - xRgCol).Column - .Range.Column + 1
With .Filters(xCount)
If .On Then
' hightlight that filter
'xRg.Offset(, I - xRgCol).Interior.Color = 16736553
xRg.Offset(, I - xRgCol).Borders(xlEdgeBottom).Weight = xlThick
xRg.Offset(, I - xRgCol).Borders(xlEdgeBottom).ColorIndex = 3
' xRg.Offset(, I - xRgCol).Borders(xlDiagonalUp).Weight = xlThick
' xRg.Offset(, I - xRgCol).Borders(xlDiagonalUp).ColorIndex = 3
' xRg.Offset(, I - xRgCol).Borders(xlDiagonalDown).Weight = xlThick
' xRg.Offset(, I - xRgCol).Borders(xlDiagonalDown).ColorIndex = 3
End If
End With
Next
End With
'go back to original position
xPos.Select
End Sub