PodCast 839 - Filter by Selection (Added more to the VBA)

[Brunoaricci]

I Thought of a way to improve on this idea:

****************
Original Post:
****************
Episode 839 - Filter by Selection
Shawn sends in a great tip for today's podcast. Access has a Filter by Selection icon. Using a few lines of VBA code, you can add this functionality to your personal macro workbook. Episode 839 shows you how.

Here is the code:
Sub Filter_by_Active_Cell()
Dim ColNum As Integer
ColNum = ActiveCell.Column - _
(ActiveCell.CurrentRegion.Column - 1)
Selection.AutoFilter Field:=ColNum, Criteria1:=ActiveCell
End Sub

Sub AutoFilterToggle()
Selection.AutoFilter
End Sub

This blog is the video podcast companion to the book, Learn Excel 97-2007 from MrExcel. Download a new two minute video every workday to learn one of the 377 tips from the book!



'**********************
'I added extra VBA after the 'show comment section
'this allows - the current filter to show in the comments section
' ****************************************

Sub Filter_by_Active_Cell()
Dim ColNum As Integer
ColNum = ActiveCell.Column - _
(ActiveCell.CurrentRegion.Column - 1)
Selection.AutoFilter Field:=ColNum, Criteria1:=ActiveCell

' show comment
Application.DisplayCommentIndicator = xlCommentAndIndicator
Dim w As Worksheet
Dim f As Integer
Dim filterset As String
Dim currentFiltRange As String
Dim myrange As Range
Set w = ActiveSheet
If w.AutoFilterMode = False Then
Application.DisplayCommentIndicator = xlNoIndicator
MsgBox ("Filters are not on. Turn on Data / Filter / AutoFilter and then run this macro again")
End
End If
Application.DisplayCommentIndicator = xlCommentAndIndicator
With w.AutoFilter
currentFiltRange = .Range.Address
With .Filters
' MsgBox ("You current Filtered DataRange to be processed is " & currentFiltRange & ". Press OK to Continue")
For f = 1 To .Count
filterset = ""
With .Item(f)
If .On Then
filterset = filterset & .Criteria1
If .Operator Then
filterset = filterset & .Operator
filterset = filterset & .Criteria2
End If
End If
End With
Set myrange = w.AutoFilter.Range(f)
On Error Resume Next
myrange.Comment.Delete
On Error GoTo 0
If filterset <> "" Then
myrange.AddComment filterset
With myrange.Comment
.Shape.TextFrame.Characters.Font.Size = 7
.Shape.TextFrame.AutoSize = True
.Shape.ScaleHeight 0.8, msoFalse, msoScaleFromTopRight
.Shape.Fill.ForeColor.SchemeColor = 5
.Shape.IncrementLeft -70
If .Shape.Height <= Rows(1).Height Then
.Shape.Top = Rows(1).Top + (Rows(1).Height - .Shape.Height) / 20
Else
.Shape.Top = Rows(1).Top - (.Shape.Height - Rows(1).Height) / 2
End If
End With
' MsgBox ("Current filter for column labeled as '" & myrange & "' " & filterset)
End If
Next f
End With
End With



End Sub


' **********************************************************


Sub AutoFilterToggle()
Selection.AutoFilter

' new - I added this to turn off comments
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub





I wish there was a way to have the Comment fit better in the CELL. but this is what I cam up with.


Any Ideas to improve this?

THanks,


Bruno

 

[JohnCM]

Can someone look into why this macro does not work to filter with dates. It will add the filter to the selection but the result is 0 records from the group.

John M.

 

[Brunoaricci]

OK - Since COmments are a bit of a problem and other comments will display that are active on the sheet I have a new solution/improvement to use. (By way of the STATUS BAR instead) try:

Sub Filter_by_Active_Cell()
Dim ColNum As Integer
ColNum = ActiveCell.Column - _
(ActiveCell.CurrentRegion.Column - 1)
Selection.AutoFilter Field:=ColNum, Criteria1:=ActiveCell

' show comment
Application.DisplayStatusBar = False
' Application.DisplayCommentIndicator = xlCommentAndIndicator
Dim w As Worksheet
Dim f As Integer
Dim filterset As String
Dim currentFiltRange As String
Dim myrange As Range
Set w = ActiveSheet
If w.AutoFilterMode = False Then
Application.DisplayCommentIndicator = xlNoIndicator
MsgBox ("Filters are not on. Turn on Data / Filter / AutoFilter and then run this macro again")
End
End If
' Application.DisplayCommentIndicator = xlCommentAndIndicator
With w.AutoFilter
currentFiltRange = .Range.Address
With .Filters
' MsgBox ("You current Filtered DataRange to be processed is " & currentFiltRange & ". Press OK to Continue")
For f = 1 To .Count
filterset = ""
With .Item(f)
If .On Then
filterset = filterset & .Criteria1



' Application.StatusBar = "Last Filter Item Applied was " & .Criteria1
If .Operator Then
filterset = filterset & .Operator

filterset = filterset & .Criteria2


End If
End If
End With
Set myrange = w.AutoFilter.Range(f)
On Error Resume Next
myrange.Comment.Delete
On Error GoTo 0
Application.DisplayStatusBar = True

If filterset <> "" Then
' myrange.AddComment filterset
' With myrange.Comment
'.Shape.TextFrame.Characters.Font.Size = 7
'.Shape.TextFrame.AutoSize = True
'.Shape.ScaleHeight 0.8, msoFalse, msoScaleFromTopRight
'.Shape.Fill.ForeColor.SchemeColor = 5
'.Shape.IncrementLeft -70
'If .Shape.Height <= Rows(1).Height Then
'.Shape.Top = Rows(1).Top + (Rows(1).Height - .Shape.Height) / 20
'Else
'.Shape.Top = Rows(1).Top - (.Shape.Height - Rows(1).Height) / 2
'End If

If f = 1 Then F1 = "COL1" & filterset & " | "
If f = 2 Then F2 = "COL2" & filterset & " | "
If f = 3 Then F3 = "COL3" & filterset & " | "
If f = 4 Then F4 = "COL4" & filterset & " | "
If f = 5 Then F5 = "COL5" & filterset & " | "
If f = 6 Then F6 = "COL6" & filterset & " | "
If f = 7 Then F7 = "COL7" & filterset & " | "
If f = 8 Then f8 = "COL8" & filterset & " | "
If f = 9 Then f9 = "COL9" & filterset & " | "
If f = 10 Then f10 = "COL10" & filterset & " | "
If f = 11 Then f11 = "COL11" & filterset & " | "
If f = 12 Then f12 = "COL12" & filterset & " | "
If f = 13 Then f13 = "COL13" & filterset & " | "
If f = 14 Then f14 = "COL14" & filterset & " | "
If f = 15 Then f15 = "COL15" & filterset & " | "
If f = 16 Then f16 = "COL16" & filterset & " | "
If f = 17 Then f17 = "COL17" & filterset & " | "
If f = 18 Then f18 = "COL18" & filterset & " | "
If f = 19 Then f19 = "COL19" & filterset & " | "
If f = 20 Then f20 = "COL20" & filterset & " | "
If f = 21 Then f21 = "COL21" & filterset & " | "
If f = 22 Then f22 = "COL22" & filterset & " | "
If f = 23 Then f23 = "COL23" & filterset & " | "
If f = 24 Then f24 = "COL24" & filterset & " | "
If f = 25 Then f25 = "COL25" & filterset & " | "
If f = 26 Then f26 = "COL26" & filterset & " | "
If f = 27 Then f27 = "COL27" & filterset & " | "
If f = 28 Then f28 = "COL28" & filterset & " | "
If f = 29 Then f29 = "COL29" & filterset & " | "
If f = 30 Then f30 = "COL30" & filterset & " | "

If f > 30 Then f31 = "Filter selections have been made beyond column 30."

' If f = 11 Then F11 = "...ONLY 10 FILTERS ARE ALLOWED TO DISPLAY"


Application.StatusBar = "Current Filters: " & F1 & F2 & F3 & F4 & F5 & F6 & F7 & f8 & f9 & f10 & f11 & f12 & f13 & f14 & f15 & f16 & f17 & f18 & f19 & f20 & f21 & f22 & f23 & f24 & f25 & f26 & f27 & f28 & f29 & f30 & f31
' End With
' MsgBox ("Current filter for column labeled as '" & myrange & "' " & filterset)
End If
Next f




End With
End With



End Sub

Sub AutoFilterToggle()
Selection.AutoFilter
Application.DisplayStatusBar = False
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End Sub

 

[MrExcel]

The ironic postscript to this podcast came in episode 851....Microsoft built "Filter by Selection" into Excel 2003! To find it:

1) Tools - Customize
2) Go to the Command Tab
3) Choose Data from the Categories tab on the left side
4) Now - the 4th button on the right side is called "AutoFilter". Drag this button to your toolbar.

This is an excellent example of a mis-labeled icon. While you would think the icon would turn on the AutoFilter dropdowns, it actually does a Filter by Selection. Even if the AutoFilter is turned off, choose one value in one column and click the icon. Excel will turn on the AutoFilter and filter to the selected value.

Bill