April 05, 2006

Excel Dialog Box Example - Find By Color

Earlier Excel versions don't always have some of the features found in later versions. Well, this much should be obvious, the trick is making a workaround to do the same thing.

Let's consider finding cells with a specified color. Rather than use a userform with a color pallete, how about using an Excel color pallet that already exists?

In this case, the Patterns dialog box. It's the same one used with Format Cells on the Right Click menu.

This code shows the dialog box itself.

Application.Dialogs(xlDialogPatterns).Show



Once we know how to do that, we can use it to color something, in this case the active cell of a selected range and then loop through each one of these cells and select those that have the same color. Two things to keep in mind are these.

1. The orginal color of the Active Cell may be the same color as we wish to look for. This means it should be included in the loop, otherwise it should be disregarded.

2. Regardless whether the orginal color is the one we want, if we set it back to the same color after the code has run, we can be sure that all of the cell colors were the same as they were before.

Here's the code. Try to spot where the above points are included. (Make sure your range is selected first)

Sub FindByColor()
    On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub
    Dim aColor As Long, rColor As Long
    Dim c As Range, aCell As Range
    Dim myRange As Range, colorRange As Range
    Set aCell = ActiveCell
    Set myRange = Selection
    Application.ScreenUpdating = False
    aCell.Select
    aColor = aCell.Interior.ColorIndex
    Application.Dialogs(xlDialogPatterns).Show
    rColor = aCell.Interior.ColorIndex
    If aColor = rColor Then
        For Each c In myRange
            If c.Interior.ColorIndex = rColor Then
                If colorRange Is Nothing Then
                    Set colorRange = c
                Else
                    Set colorRange = Union(colorRange, c)
                End If
            End If
        Next
    Else
        For Each c In myRange
            If c.Interior.ColorIndex = rColor _
               And c.Address <> aCell.Address Then
                If colorRange Is Nothing Then
                    Set colorRange = c
                Else
                    Set colorRange = Union(colorRange, c)
                End If
            End If
        Next
    End If
    colorRange.Select
    aCell.Interior.ColorIndex = aColor
    Application.ScreenUpdating = True
    ' Clean up after the code has run
    Set aCell = Nothing
    Set myRange = Nothing
    Set colorRange = Nothing
    On Error GoTo 0
End Sub

Of course, we can expand on this to do all kinds of things if the right type of dialog box is available. Using Excel to work with Excel, waste not, want not ;-)