Improving Workbook_SheetSelectionChange for enhanced Autofiltering

[aafraga]

Dear Community,

I have coded an enhanced Autofilter algorithm that provides improved
funtionality for Autofilter users. Hopefully, I have not replicated
existing work in Excel.

I seem to have a problem with the event handler. Essentially, the row
above the Autofilter header now becomes a field to define criteria.
Essentially, the problem lies with the event
Workbook_SheetSelectionChange not activating upon a change to the cell.
This means that you need to revisit the cell for the macro to perform
its work.

All the code has been included. This resides in the ThisWorkbook
object. Improvements and fixes would be very much apprciated.

Alberto


Code:
--------------------

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

If ActiveSheet.AutoFilterMode Then

Dim af As AutoFilter
Set af = ActiveSheet.AutoFilter

Dim afCols As Integer
afCols = af.Range.Columns.Count

Dim afStart As Range
Set afStart = af.Range(1, 1)

If Target.Count = 1 Then
If InRange(Target, Range(afStart.Offset(-1, 0), afStart.Offset(-1, afCols - 1))) Then
If Target = "" Then
Selection.AutoFilter Field:=(Target.Column - afStart.Column + 1)
Else
searchPattern = Target
If Left(Target, 1) <> "<" And Left(Target, 1) <> ">" And Left(Target, 1) <> "=" Then
searchPattern = searchPattern & "*"
End If
Selection.AutoFilter Field:=(Target.Column - afStart.Column + 1), Criteria1:=searchPattern
End If 'NullTarget
End If 'InRange
End If 'Just One cell selected
End If 'AutoFilterMode
End Sub


Private Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2
Dim InterSectRange As Range
Set InterSectRange = Application.Intersect(Range1, Range2)
InRange = Not InterSectRange Is Nothing
Set InterSectRange = Nothing
End Function

 

[Bob Phillips]

Alberto,

It seems to work fine for me. I have a value in say B1 and filter B2 down,
change B1 and the filtered list changes. I assume that this is what you are
trying to do.

Although it works, you might want to change to the SheetChange event rather
than the SheetSelectionChange.

Also, you are not using formulae to calculate the criteria filed are you?

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[aafraga]

Hi Bob
Many thanks for your suggestion of changin
Workbook_SheetSelectionChange to Workbook_SheetChange. It does improv
the usability however there still are some problematic issues

If you have a large data set in a work sheet (say range a3:g100), wit
the column headers defined in row 3 and also defined as the Autofilte
row. If you then define various criteria for various columns in row
(please note that you can define logical formula. lets imagine column
contains a numeric value representing age, you can type <10 in cell f
for filtering age less than 10)

The problem I have is that if you want to delete all the criteria i
row 2, lets say by highlighting the row, then hitting delete key t
remove all entries along the row, the data stays in filtered mode
rather than showing the unfiltered data

Any suggestions on how to modify the code so as to fix this problem
Many thanks for the help
Albert

 

[Bob Phillips]

Hi Alberto,

I get the problem now.

Try this (watch wrap-around)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim searchPattern
Dim cell As Range

If ActiveSheet.AutoFilterMode Then

Dim af As AutoFilter
Set af = ActiveSheet.AutoFilter

Dim afCols As Integer
afCols = af.Range.Columns.Count

Dim afStart As Range
Set afStart = af.Range(1, 1)

For Each cell In Target
If InRange(cell, Range(afStart.Offset(-1, 0), afStart.Offset(-1,
afCols - 1))) Then
If cell = "" Then
Selection.AutoFilter Field:=(cell.Column -
afStart.Column + 1)
Else
searchPattern = cell
If Left(cell, 1) <> "<" And Left(cell, 1) <> ">" And _
Left(cell, 1) <> "=" Then
searchPattern = searchPattern & "*"
End If
Selection.AutoFilter Field:=(cell.Column -
afStart.Column + 1), _
Criteria1:=searchPattern
End If 'NullTarget
End If 'InRange
Next cell
End If 'AutoFilterMode
End Sub

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[aafraga]

Hi Bob,

Magic. Thanks for the help. Your modifications have helped me attain
the exact implementation I required.

For the benefit of others, I have pasted the complete final code (with
remarks)

Code:
--------------------

'Programmer: Alberto Andrade-Fraga
'Proram Coded: 10 April 2005
'Program Version: 1.1
'Please send modificiation that improves the functionality to
'email: (e-mail address removed)
'
'Purpose:
' Enhance the AutoFilter mode by providing simple criteria based filtering
'
'Implementation:
' Program autodetects the location and the size of the Autofilter header and uses the first row
' above the Autofilter header to create the criteria and filter the data.
' The * wildcard can be used to locate patterns in a string. Eg. *Andrade would search for
' a string containing Andrade. Logical constucts can be used to test for greater and equality
'
'Modifications:
' 1.1 Implementation of ActiveSheet to make code generic to workbook.
' 1.1 Limit the scope of the macro to the cells directly above the Autofilter header
' 1.1 Change event handlet to SheetChange to make more robust
' 1.1 For each cell in Range implemented to handle criteria deletion and Autofilter reset.
'
'Carried out for Davide at ABN Amro
'Concept by Alberto with thanks to Bob Phillips of ExcelTip Forum.


Private Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2
Dim InterSectRange As Range
Set InterSectRange = Application.Intersect(Range1, Range2)
InRange = Not InterSectRange Is Nothing
Set InterSectRange = Nothing
End Function


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim searchPattern
Dim cell As Range

If ActiveSheet.AutoFilterMode Then

Dim af As AutoFilter
Set af = ActiveSheet.AutoFilter

Dim afCols As Integer
afCols = af.Range.Columns.Count

Dim afStart As Range
Set afStart = af.Range(1, 1)

For Each cell In Target
If InRange(cell, Range(afStart.Offset(-1, 0), afStart.Offset(-1, afCols - 1))) Then
If cell = "" Then
Selection.AutoFilter Field:=(cell.Column - afStart.Column + 1)
Else
searchPattern = cell
If Left(cell, 1) <> "<" And Left(cell, 1) <> ">" And Left(cell, 1) <> "=" Then
searchPattern = searchPattern & "*"
End If 'Logical Formula Criteria
Selection.AutoFilter Field:=(cell.Column - afStart.Column + 1), Criteria1:=searchPattern
End If 'Is Empty Cell
End If 'In Range
Next cell

End If 'AutoFilterMode
End Sub

 

[Bob Phillips]

Not to carp or anything Alberto, but I am not in the ExcelTip forum, I am in
the Microsoft public newsgroups. Questions posted at ExcelTip get forwarded
to the public NGs. I never persoanlly use ExcelTip.

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)