Generalize the ColorForUnique code

[byronwall]

Right now it uses a hard coded range. Need to based this on user input / Selection. It is also not wired up to a button or the Ribbon.

[RaymondWise]

I made a go at this, changed the method of picking random colors though. We can change it to exclude certain colors, if needed.

Sub ColorForUnique()

    Dim dict As New Scripting.Dictionary
    Set dict = CreateObject("Scripting.Dictionary")

    'We can only match based on one column - so select that column
    Dim rngToMatch As Range
TryAgain:
    Set rngToColor = Application.InputBox("Select column to color", Type:=8)
    If rngToColor.Columns.count > 1 Then
        MsgBox ("You can only color based on one column")
        GoTo TryAgain
    End If

    'We can colorize the sorting column, or the entire row
    allrows = MsgBox("Do you want to color the entire row?", vbYesNo)

    Application.ScreenUpdating = False
    Set rngToColor = Intersect(rngToColor, ActiveSheet.UsedRange)

    rngToColor.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    Dim iCount As Integer
    iCount = rngToColor.SpecialCells(xlCellTypeVisible).count

    Dim iColors As Integer
    For i = 1 To iCount
FindaColor:
        iColors = Int((56) * Rnd + 1)
        If dict.Exists(iColors) Then
            GoTo FindaColor
        End If
        dict(iColors) = iColors
    Next



    Dim j As Integer
    j = 0
    If allrows = vbNo Then

        For Each c In rngToColor.SpecialCells(xlCellTypeVisible)
                'Row 1 contains headers, so skip
                 If Not c.Row = 1 Then
                    c.Interior.ColorIndex = dict.Items(j)
                    j = j + 1
                 End If
        Next

    End If

    If allrows = vbYes Then

        For Each c In rngToColor.SpecialCells(xlCellTypeVisible)
                 If Not c.Row = 1 Then
                    c.EntireRow.Interior.ColorIndex = dict.Items(j)
                    j = j + 1
                 End If
        Next


    End If

   ActiveSheet.ShowAllData
   Application.ScreenUpdating = True
End Sub

[byronwall]

On a quick test, this seems to only color the first instance of a given item. I think the key for the Dictionary should be the cell value that way you can assign a color to a unique value and then reference that down below when the colors are applied to the cells. Down below, the colors should be applied to all of the cells and not just the first entry.

Example picture has a pair of duplicates: 74 and 97 (97 is the all black cell). I would expect both of the no background cells to match their corresponding formatted cell.

So when creating the colors, I would iterate through rngToColor.SpecialCells(xlCellTypeVisible) and when assigning the colors, I would iterate through the entire range: rngToColor and pull the color based on the value in the cell. This would replace the two numerical loops.

I agree on possible excluding some colors. Assigning random colors is always a crap shoot. There are too many colors that look black and make the text impossible to see. There might be a way to evaluate "darkness" (maybe that's lightness in HSL?) and exclude colors too close to black (or the font color). I think that is adequate enough and we don't need to worry about font color. It may also be possible to use the RandBetween approach and do it between (100,200) to avoid getting too dark or white. My only concern with using ColorIndex is that it's possible to run this on something with more than 56 unique items at which point it will loop endlessly to find a color.

Other comments:

• I like the ability to color the entire row
• I think it may be possible to consider uniqueness of multiple columns. Does Advanced Filter handle that filter out of the box? If so, the key for the color part could be Join(rngWithMultipleColumns, "||") or similar using the same code from CombineCells.
• Finally, the ShowAllData will fail if all the entries were unique since there seems to be no filter in place. Maybe a check on AutoFilterMode to prevent that? Can't remember how the advanced filter indicates its presence on a sheet.

[RaymondWise]

I didn't realize it was to color each item a different color, rather than just one for each unique item.

We can check for the filter with

If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False

Very good call about running out of colors, I hadn't thought of that.

[byronwall]

I went back to something closer to the original with the InputBox prompts that you added. The version in there now allows for a multi-column key, prompts on coloring the entire row, and uses the random colors from 50 to 255. I also kept the duplicate color check (added it in a second commit).

While testing that, I discovered that Excel has a limit for the number of unique cell formats that are supported. It's around 65,000. In any case, using this to color more than that number of unique items leads to an error. Fixing the spreadsheet after removing the formats is not easy. I had to use a third party tool.

I doubt anyone uses this to color 65k+ unique entries, but it's worth noting that this may contaminate some of the sheet formats if applied to a large range.

The tool linked in this SO answer works well to solve it though: http://stackoverflow.com/a/2460011/4288101.

At this point, I am going to call this one killed. It works on general ranges as intended.