ExcelBanter - autofilter macro

Hi,

"any help?"
This is overkill but have a look at my homemade macro & function listed
below, because it is homemade it isn't totally bulletproof/polished but
considers some potential issues. It may be more detailed than you
require but I find it fast & very useful as it uses an input box rather
than textboxes for the search criteria & I have it stored in my
personal.xls & assigned to a shortcut key.
(I'm pretty sure this is the same as my newest version but can't
confirm, as that is in the office).
btw, The part commented with '*** shows how to allow for the search
being cancelled.
nb: there may be word wrap issues that need to be checked.

Sub EnhancedQuickFilterNEWer050306()
'written by Rob Brockett (NZ)
Application.ScreenUpdating = False
Dim ColToFilter As Long
ColToFilter = ActiveCell.Column
Dim InitialFilterValue As String
Dim FilterValue As String
Dim FilterValueDate As Date
Dim StringPrefix As String
Dim CurrentCellFormat As String
CurrentCellFormat = ActiveCell.NumberFormat
Dim DateCheck As Long

InitialFilterValue = InputBox("SHORT CUT CODES:" & Chr(13) & Chr(13) &
_
"[BLANK] = Show all rows with/containing value of current cell." &
Chr(13) & _
"[SPACE] = Show all rows in active column." & Chr(13) & _
"[SPACE SPACE] = Show all rows in all columns." & Chr(13) & _
"[SPACE SPACE SPACE] = Show all rows with blanks." & Chr(13) & _
"[-] = Hide all rows with current cell value." & Chr(13) & _
" = Hide all rows with blanks in this column." & Chr(13) & _
"[<?] = Show all rows with values less than ?" & Chr(13) & _
"[?] = Show all rows with values greater than ?" & Chr(13) & _
"[<] = Show all rows with values less than current cell or entered
value." & Chr(13) & _
"[] = Show all rows with values greater than current cell or entered
value." & Chr(13) & Chr(13), "QUICK FILTER")

'***To end sub if "cancel" was pressed sourced from _
http://www.excelforum.com/showthread...vbcancel+input
& http://vb.mvps.org/tips/varptr.asp
If StrPtr(InitialFilterValue) = 0 Then
GoTo ExitSub
Else
End If

Select Case Len(InitialFilterValue)
Case 0
'ErrorCheckOfActiveCell
FilterValue = PossibleErrorCodeOfActiveCell
Selection.AutoFilter Field:=ColToFilter, Criteria1:="=" &
FilterValue, Operator:=xlOr, _
Criteria2:="=*" & FilterValue & "*"
GoTo ExitSub
Select Case Len(ActiveCell)
Case Is < 0
'Checks if current cell is a date & shows FilterValue
of current cell _
using various methods
If IsDate(ActiveCell) Then
'***
RepeatedAttemptToFilterActiveCellByDate:
DateCheck = DateCheck + 1
Select Case DateCheck
Case 1
FilterValue = ActiveCell
Case 2
FilterValue = CLng(CDate(ActiveCell))
Case 3
FilterValue =
Format(DateSerial(Year(ActiveCell), Month(ActiveCell),
Day(ActiveCell)), "dd/mm/yy")
Case 4
FilterValue =
Format(DateSerial(Year(ActiveCell), Month(ActiveCell),
Day(ActiveCell)), "dd/mm/yyyy")
Case 5
FilterValue =
Format(DateSerial(Year(ActiveCell), Month(ActiveCell),
Day(ActiveCell)), CurrentCellFormat)
Case 6
MsgBox "Date Filter not working, please use the
manual method of custom filtering."
GoTo ExitSub
End Select
Else
FilterValue = ActiveCell
End If
Selection.AutoFilter Field:=ColToFilter,
Criteria1:="=" & FilterValue
If ActiveCell.EntireRow.Hidden Then
If Len(InitialFilterValue) = 0 Then
GoTo RepeatedAttemptToFilterActiveCellByDate:
Else
End If
Else
End If
'***
Case 0
'Shows blank cells when active cell is empty
Selection.AutoFilter Field:=ColToFilter, Criteria1:="="
End Select
Case Else
Select Case Left(InitialFilterValue, 1)
Case " "
Select Case InitialFilterValue
Case " "
'show all in current column (1 space).
Selection.AutoFilter Field:=ColToFilter
GoTo ExitSub
Case " "
'To remove all any active filters on any filterable
column (2 spaces).
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
GoTo ExitSub
Case " "
'Shows blank cells when active cell is not empty (3
spaces).
Selection.AutoFilter Field:=ColToFilter,
Criteria1:="="
End Select
Case "<"
Select Case Left(InitialFilterValue, 2)
Case "<", "<="
GoTo MakeStringPrefixDoubleLeft
Case Else
GoTo MakeStringPrefixSingleLeft
End Select
Case ""
Select Case Left(InitialFilterValue, 2)
Case "="
GoTo MakeStringPrefixDoubleLeft
Case Else
GoTo MakeStringPrefixSingleLeft
End Select
Case "-"
Select Case InitialFilterValue
Case "-"
'Hide rows
FilterValue = PossibleErrorCodeOfActiveCell
Selection.AutoFilter Field:=ColToFilter,
Criteria1:="<" & FilterValue
Exit Sub
Case Else
'allows for filtering of negative values
GoTo MakeStringPrefixSingleLeft:
End Select
Case "*"
'Shows all non blanks (hides blanks)
Selection.AutoFilter Field:=ColToFilter, Criteria1:="<"
GoTo ExitSub
Case "="
'To limit visible rows to exact matches
Select Case InitialFilterValue
Case "="
FilterValue = PossibleErrorCodeOfActiveCell
Case Else
FilterValue = Right(InitialFilterValue,
Len(InitialFilterValue) - 1)
GoTo ExitSub
End Select
Selection.AutoFilter Field:=ColToFilter,
Criteria1:=FilterValue
Case Else
FilterValue = InitialFilterValue
GoTo ContinueAfterSettingStringPrefix
End Select

MakeStringPrefixSingleLeft:
StringPrefix = Left(InitialFilterValue, 1)
If Len(InitialFilterValue) = 1 Then
FilterValue = ActiveCell
Else
FilterValue = Right(InitialFilterValue, Len(InitialFilterValue) - 1)
End If
GoTo ContinueAfterSettingStringPrefix

MakeStringPrefixDoubleLeft:
StringPrefix = Left(InitialFilterValue, 2)
If Len(InitialFilterValue) = 2 Then
FilterValue = ActiveCell
Else
FilterValue = Right(InitialFilterValue, Len(InitialFilterValue) - 2)
End If

ContinueAfterSettingStringPrefix:
If StringPrefix = "<" Then
Selection.AutoFilter Field:=ColToFilter, Criteria1:=StringPrefix &
FilterValue
Else
If StringPrefix = "-" Then
Selection.AutoFilter Field:=ColToFilter, Criteria1:="<" &
FilterValue, Operator:=xlOr, _
Criteria2:="<*" & FilterValue & "*"
Else
Selection.AutoFilter Field:=ColToFilter, Criteria1:=StringPrefix &
FilterValue, Operator:=xlOr, _
Criteria2:="=*" & FilterValue & "*"
End If
End If
End Select
ExitSub:
Application.ScreenUpdating = True
End Sub

Public Function PossibleErrorCodeOfActiveCell()
'To allow filtering of cells with errors (the commented # to the _
right is the error value.
If IsError(ActiveCell) Then
Select Case ActiveCell
Case CVErr(xlErrDiv0) '2007
PossibleErrorCodeOfActiveCell = "#DIV/0!"
Case CVErr(xlErrNA) '2042
PossibleErrorCodeOfActiveCell = "#N/A"
Case CVErr(xlErrName) '2029
PossibleErrorCodeOfActiveCell = "#NAME?"
Case CVErr(xlErrNull) '2000
PossibleErrorCodeOfActiveCell = "#NULL!"
Case CVErr(xlErrNum) '2036
PossibleErrorCodeOfActiveCell = "#NUM!"
Case CVErr(xlErrRef) '2023
PossibleErrorCodeOfActiveCell = "#REF!"
Case CVErr(xlErrValue) '2015
PossibleErrorCodeOfActiveCell = "#VALUE!"
End Select
Else
PossibleErrorCodeOfActiveCell = ActiveCell
End If
End Function

Please let me know if it helps/you have any suggestions.
hth,
Rob Brockett
NZ
Always learning & the best way to learn is to experience...

--
broro183
------------------------------------------------------------------------
broro183's Profile: http://www.excelforum.com/member.php...o&userid=30068
View this thread: http://www.excelforum.com/showthread...hreadid=533724