VBA Excel 基于唯一值将条件格式应用于单元格

VBA Excel Apply Conditional Format to Cells Based on Unique Values

提问by Ted J

I would like to conditionally format a column with each unique value getting its own unique cell background color. I run a report where we add a Section Description column for sorting purposes. For visual aid, I'd like to be able to assign a color to each Section Description.

我想有条件地格式化一个列，每个唯一值都有自己唯一的单元格背景颜色。我运行了一个报告，其中我们添加了一个 Section Description 列以进行排序。为了视觉辅助，我希望能够为每个部分描述分配一种颜色。

The flow is:

流程是：

1. Run the Report
2. Section Descriptions are added
3. Run the macro to assign unique colors per section

1. 运行报告
2. 添加了部分说明
3. 运行宏为每个部分分配唯一的颜色

The issue I have run into is that each time we run the report there might be a different number of section descriptions that are added. Therefore, I'm not sure how to assign unique colors when there could be anywhere from 3 sections to 20 sections.

我遇到的问题是，每次我们运行报告时，可能会添加不同数量的部分描述。因此，当可能有 3 个部分到 20 个部分时，我不确定如何分配独特的颜色。

My rough idea is as follows:

我的粗略想法如下：

(a. Remove all conditional formatting from column A)

(a. 从 A 列中删除所有条件格式)

1. Look through column A (where the descriptions are) and find all of the unique values
2. Paste the unique values in a separate sheet
3. Go through each unique value and assign a color from a group of colors
4. Assign the conditional format to column A on my main sheet based on the assignments from step 3

1. 查看 A 列（描述所在的位置）并找到所有唯一值
2. 将唯一值粘贴到单独的工作表中
3. 遍历每个唯一值并从一组颜色中分配一种颜色
4. 根据步骤 3 中的分配，将条件格式分配给我的主工作表上的 A 列

The other way that this could be done would be to run this process every time a value is changed in column A.

另一种方法是每次更改 A 列中的值时运行此过程。

In terms of a color library it might be nice to have more neutral colors that stick out. I don't need bright neon greens and such.

就颜色库而言，拥有更多突出的中性颜色可能会很好。我不需要明亮的霓虹绿之类的。

Any help would be greatly appreciated!

任何帮助将不胜感激！

Sub ColorDescriptions()
'
' ColorDescriptions Macro
'
    Dim Grid As Worksheet
    Dim lastRowGridA As Long

    Set Grid = Sheets("Grid")

' get the last row from column A that has a value
    lastRowGridA = Grid.Range("A" & Grid.Rows.Count).End(xlUp).Row

' move values to STORED VALUES

    Range("A6:A" & lastRowGridA).Select
    Selection.Copy
    Sheets("STORED VALUES").Select
    Range("F2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

' remove duplicates

ActiveSheet.Range("$F:$F$" & lastRowGridA).RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("A1").Select

' apply conditional formatting

Dim lastRowSVF As Long
Dim Z As Integer
Set SV = Sheets("STORED VALUES")

lastRowSVF = SV.Range("F" & SV.Rows.Count).End(xlUp).Row

Z = 2
Do
Range("G" & Z).Value = Z
Z = Z + 1
Loop Until Z = lastRowSVF + 1


End Sub

So right now this is working and I get all of my unique values and I am able to loop through successfully and stop when I get to the last value. The next step is to replace the...

所以现在这是有效的，我得到了我所有的唯一值，我能够成功循环并在我到达最后一个值时停止。下一步是更换...

Range("G" & Z).Value = Z
Z = Z + 1

...after the Do, to create conditional formatting using the info from the list.

...在 Do 之后，使用列表中的信息创建条件格式。

The replacement will use something like:

替换将使用以下内容：

Sheets("Grid").Select
Columns("A:A").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
    Formula1:="='STORED VALUES'!$F"
' $F will need to change as we loop through the list
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
'Color will need to change as we loop through the list, I'm guessing I can use
'something like Z to define the color
    .Color = 5287936
    .TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A1").Select
Sheets("STORED VALUES").Select
Range("F1").Select  

I think I am close, but I'm just having trouble with the loop. Once the loop is working, I'd like to be able to tweak the colors that are used also.

我想我已经接近了，但我只是在循环中遇到了麻烦。一旦循环开始工作，我希望能够调整所使用的颜色。

The end goal is that after I run the macro, each value in column A in my Grid sheet will have a conditional format based on the unique values in column A.

最终目标是在我运行宏之后，网格表中 A 列中的每个值都将具有基于 A 列中唯一值的条件格式。

回答by David Zemens

I decided not to do the gradient thing, and instead foudn a function that generates random color values. This is used with the Interior.ColorIndexand not the Long color values.

我决定不做渐变的事情，而是找到一个生成随机颜色值的函数。这与Interior.ColorIndexlong 颜色值一起使用，而不是与 Long 颜色值一起使用。

This should get you started:

这应该让你开始：

Sub ColorDescriptions()
    Dim Grid As Worksheet
    Dim lastRowGridA As Long
    Dim gridRange As Range
    Dim r As Range 'row iterator
    Dim dictValues As Object 'Scripting.Dictionary
    Dim dictColors As Object 'Scripting.Dictionary

    Set Grid = Sheets(2)
    Set dictValues = CreateObject("Scripting.Dictionary")
    Set dictColors = CreateObject("Scripting.Dictionary")
    Set gridRange = Grid.UsedRange.Columns("A:A")
    'I use a scripting dictionary since it only allows unique keys:
    For Each r In gridRange.Cells
        If Not dictValues.Exists(r.Value) Then
            'This dictionary stores what color to use for each key value
            dictValues(r.Value) = intRndColor(dictColors)
            dictColors(dictValues(r.Value) = ""
        End If

        If dictColors.Count <= 56 Then
            r.Interior.ColorIndex = dictValues(r.Value)
        Else:
            MsgBox "Too many unique values to use only 56 color palette"

        End If
    Next
' apply conditional formatting

''' the rest of your code/

End Sub

'modified from
' http://www.ozgrid.com/forum/showthread.php?t=85809
Function intRndColor(dict)
     'USE - FUNCTION TO PICK RANDOM COLOR, ALSO ALLOWS EXCLUSION OF COLORS YOU DON'T LIKE
    Dim Again As Label
Again:
    intRndColor = Int((50 * Rnd) + 1) 'GENERATE RANDOM IN

    If dict.Exists(intRndColor) Then GoTo Again

    Select Case intRndColor
    Case Is = 0, 1, 3, 21, 35, 36 'COLORS YOU DON'T WANT; Modify as needed
        GoTo Again
    End Select

End Function

回答by Ted J

Thanks David for your help. I ended up solving my issue by finding colors I liked and making sure I only used these colors. I tried assigning random colors but it wasn't feasible. This method takes only a few colors and assigns them through my descriptors.

感谢大卫的帮助。我最终通过找到我喜欢的颜色并确保我只使用这些颜色来解决我的问题。我尝试分配随机颜色，但这是不可行的。这个方法只需要几种颜色并通过我的描述符分配它们。

Sub ColorDescriptions()
'
' ColorDescriptions Macro
'
' Turn Screen flashing off

Application.ScreenUpdating = False


Dim Grid As Worksheet
Dim lastRowGridA As Long

Set Grid = Sheets("Grid")

Sheets("Grid").Select

'Sort everything by Section Description

Rows("5:5").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Grid").AutoFilter.Sort.SortFields.Add Key:=Range( _
    "A5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Grid").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Selection.AutoFilter


' get the last row from column A that has a value
lastRowGridA = Grid.Range("A" & Grid.Rows.Count).End(xlUp).Row

' move values to STORED VALUES
Sheets("Grid").Select
Range("A6:A" & lastRowGridA).Select
Selection.Copy
Sheets("STORED VALUES").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

' remove duplicates

ActiveSheet.Range("$F:$F$" & lastRowGridA).RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("A1").Select

' apply conditional formatting

Dim lastRowSVF As Long
Dim Z As Integer
Dim A As Integer
Dim B As Integer

Set SV = Sheets("STORED VALUES")

lastRowSVF = SV.Range("F" & SV.Rows.Count).End(xlUp).Row

Z = 2
A = 11
B = 12

Do

If (Z Mod 8) + 2 = 2 Then
D = A
ElseIf (Z Mod 8) + 2 = 3 Then
D = B
Else: D = (Z Mod 8) + 2
End If

Sheets("Grid").Select
Columns("A:A").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
    Formula1:="='STORED VALUES'!$F$" & Z
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .PatternTintAndShade = 0
    .ThemeColor = xlThemeColorAccent & D
    .TintAndShade = 0.6
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A1").Select
Sheets("STORED VALUES").Select

'This next section is used to document the colors being assigned and the method

Range("G" & Z).Value = Z
Range("H" & Z).Value = "xlThemeColorAccent" & D
Range("I" & Z).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent & D
    .TintAndShade = 0.6
    .PatternTintAndShade = 0
End With

Z = Z + 1
Loop Until Z = lastRowSVF + 1


End Sub