Generalize the ColorForUnique code
byronwall opened this issue · 4 comments
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.
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
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, thekey
for the color part could beJoin(rngWithMultipleColumns, "||")
or similar using the same code fromCombineCells
. - Finally, the
ShowAllData
will fail if all the entries were unique since there seems to be no filter in place. Maybe a check onAutoFilterMode
to prevent that? Can't remember how the advanced filter indicates its presence on a sheet.
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.
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.