Hi Kim,
Great question. See the attached file and complete code that follows which is based on similar code to yours. I would give credit to the author, but I lost the original link.
Please note that there can be several ranges that can use AutoFilter on one sheet, but only one AutoFilter range can be active on one sheet at a time (at least in Excel 2003). If using more than one range per sheet, they SHOULD NOT BE side by side, because when AutoFilter hides rows, it may look like a non-AutoFilter range is being filtered.
AutoFilter can be ON at the same time on several different sheets in the same workbook
I called the function 'GetAutoFilterCriteria()' and created a SHORTCUT function 'AFC() ' that does the same thing to allow for less typing when implementing the function in a cell. Even though the function is declared Volatile (which means a recalculation occurs any time any cell on the sheet needs calculation), recalculation may not occur when switching between AutoFilter OFF and AutoFilter ON when there are no Autofilter criteria.
Lewis
Option Explicit
Function AFC(Header As Range) As String
'This is a SHORTCUT (to eliminate typing) for function GetAutoFilterCriteria()
AFC = GetAutoFilterCriteria(Header)
End Function
Function GetAutoFilterCriteria(Header As Range) As String
'This returns AutoFilter Criteria for ONE AutoFilter Column as text
Dim bAutoFilterOn
Dim sCriterion1 As String
Dim sCriterion2 As String
'Recalculate any time a calculation occurs in the Worksheet
Application.Volatile
'Get the current 'AutoFilter' State
bAutoFilterOn = ActiveSheet.AutoFilterMode
If bAutoFilterOn = False Then
'Do Not Process - AutoFilter is OFF
GetAutoFilterCriteria = "AutoFilterOff"
ElseIf Header.Count > 1 Then
'Do Not Process - Input Range must be ONE CELL
GetAutoFilterCriteria = "#VALUE"
Else
'Process - AutoFilter is ON
With Header.Parent.AutoFilter
With .Filters(Header.Column - .Range.Column + 1)
If Not .On Then
GetAutoFilterCriteria = "No Filter"
Else
sCriterion1 = .Criteria1
If .Operator = xlAnd Then
sCriterion2 = " AND " & .Criteria2
ElseIf .Operator = xlOr Then
sCriterion2 = " OR " & .Criteria2
End If
GetAutoFilterCriteria = UCase(Header) & ": " & sCriterion1 & sCriterion2
End If
End With
End With
End If
End Function
Sub FilterDateUsingTwoCriteria()
Dim myStartDate As Date
Dim myEndDate As Date
myStartDate = Range("E7")
myEndDate = Range("E8")
Sheets("Sheet1").Select
With ActiveSheet
.AutoFilterMode = False
.Range("C11:E11").AutoFilter
.Range("C11:E11").AutoFilter Field:=3, _
Criteria1:=">" & CDbl(myStartDate), _
Operator:=xlAnd, _
Criteria2:="<=" & CDbl(myEndDate)
End With
End Sub
Sub AutoFilterClearAndOn()
'This Clear then Turns ON AutoFilter
With ActiveSheet
.AutoFilterMode = False
.Range("C11:E11").AutoFilter
End With
'Force recalculation of the cells that monitor AutoFilter status
Range("C28:E28").Calculate
End Sub
Sub AutoFilterOff()
'This Turns OFF AutoFilter on the Active Sheet
ActiveSheet.AutoFilterMode = False
'Force recalculation of the cells that monitor AutoFilter status
Range("C28:E28").Calculate
End Sub
Sub TestGetAutoFilterCriteriaOnlyVBADirect()
'This obtains AutoFilter Criteria using VBA only
'
'The Addresses of the AutoFilter 'Header Cells' are 'hard coded'
Dim s As String
Dim sData As String
sData = "AutoFilter Criteria:" & vbCrLf
s = "C11: " & GetAutoFilterCriteria(Range("C11"))
sData = sData & s & vbCrLf
s = "D11: " & GetAutoFilterCriteria(Range("D11"))
sData = sData & s & vbCrLf
s = "E11: " & GetAutoFilterCriteria(Range("E11"))
sData = sData & s & vbCrLf
MsgBox sData
End Sub
Sub TestGetAutoFilterCriteriaOnlyVBA()
'This obtains AutoFilter Criteria using VBA only
Dim ws As Worksheet
Dim r As Range
Dim s As String
Dim sAddress As String
Dim sCriteria As String
Dim sData As String
Dim sHeaderRange As String
'Assign the Worksheet Object
Set ws = ActiveSheet
sHeaderRange = GetAutoFilterHeaderRangeAddress(ws)
sData = "AutoFilter Criteria:" & vbCrLf
If Len(sHeaderRange) = 0 Then
sData = "AutoFilter Criteria:" & vbCrLf & "AutoFilterOff"
Else
For Each r In Range(sHeaderRange)
'Get the next 'Header Cell Address' without '$' signs
sAddress = r.Address(False, False)
'Get the 'AutoFilter' criteria for that column
sCriteria = GetAutoFilterCriteria(r)
'Add to the output string
s = sAddress & ":" & sCriteria
sData = sData & s & vbCrLf
Next r
End If
MsgBox sData
'Clear object pointers
Set r = Nothing
Set ws = Nothing
End Sub
Function GetAutoFilterRangeAddress(ws As Worksheet) As String
'This gets the address of the Active Autofilter on a given Worksheet
Dim r As Range
If ws.AutoFilterMode = True Then
Set r = ws.AutoFilter.Range
GetAutoFilterRangeAddress = r.Address(False, False)
Set r = Nothing
End If
End Function
Function GetAutoFilterHeaderRangeAddress(ws As Worksheet) As String
'This gets the address of the Active Autofilter on a given Worksheet
'
'Null String is returned if there is no 'Active AutoFilter'
'
'It is the calling routine's responsibility to make sure the Sheet Exists
'
'The 'Header Range' is the interesection of the 'AutoFilter Range' with the 'Entire Header Row'
Dim myHeaderRange As Range
Dim r1 As Range
Dim r2 As Range
Dim iHeaderRow As Long
If ws.AutoFilterMode = True Then
Set r1 = ws.AutoFilter.Range
iHeaderRow = r1.Row
Set r2 = ws.Range(ws.Rows(iHeaderRow), ws.Rows(iHeaderRow)).Rows
Set myHeaderRange = Intersect(r1, r2)
GetAutoFilterHeaderRangeAddress = myHeaderRange.Address(False, False)
Set r1 = Nothing
Set r2 = Nothing
Set myHeaderRange = Nothing
End If
End Function
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks