There are two ways I see to do this, here's one option that requires simply
that you choose a single cell in the column holding the colored cells to base
the filter on and then call the sub and you choose which color to filter by.
I'll post 2nd one as separate posting in a moment.
I did a little research and found this:
http://groups.google.com/group/micr.../e91a66c411c4ce86?hl=en&lr=&ie=UTF-8&oe=UTF-8
All but the Sub ColorTime are preparation for it. Now, if you modify that
as I have below (calling it FilterByColor instead), then you end up with a
routine that will filter by fill color of the cells in the currently selected
column. Basically it hides rows based on cell color in that row of the
column - thus filtering by color. To 'unfilter' select any entire column and
choose Format | Rows | Unhide.
Below is the entire code, including the setup and my added routine:
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As ChooseColor) As Long
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long
Private Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Function ShowColor() As Long
Dim ChooseColorStructure As ChooseColor
Dim CustomColors As Long
Dim Custcolor(16) As Long
Dim lReturn As Long
ChooseColorStructure.lStructSize = _
Len(ChooseColorStructure)
ChooseColorStructure.hwndOwner = _
FindWindow("XLMAIN", Application.Caption)
ChooseColorStructure.hInstance = 0
ChooseColorStructure.lpCustColors = _
StrConv(CustomColors, vbUnicode)
ChooseColorStructure.flags = 0
If ChooseColor(ChooseColorStructure) <> 0 Then
ShowColor = ChooseColorStructure.rgbResult
CustomColors = _
StrConv(ChooseColorStructure.lpCustColors, _
vbFromUnicode)
Else
ShowColor = -1
End If
End Function
Sub FilterByColor()
Dim colorChosen As Variant
Dim lastRow As Long
Dim rOffset As Long
' for Excel 2007 compatibility
Dim filterColumn As Long
lastRow = Cells(Rows.Count, _
Selection.Column).End(xlUp).Row
colorChosen = ShowColor
If colorChosen < 0 Then
Exit Sub
End If
filterColumn = Selection.Column
lastRow = Cells(Rows.Count, _
Selection.Column).End(xlUp).Row
Application.ScreenUpdating = False
'first unhide all rows
Range("A:A").EntireRow.Hidden = False
'assumes a title row at row 1
For rOffset = 1 To lastRow
If Cells(rOffset, filterColumn).Interior.Color <> _
colorChosen Then
Cells(rOffset, filterColumn).EntireRow.Hidden = True
End If
Next
Application.ScreenUpdating = True
End Sub
