VBA Excel применяет условный формат к ячейкам на основе уникальных значений

Я хотел бы условно форматировать столбец с каждым уникальным значением, получая свой собственный уникальный цвет фона ячейки. Я запускаю отчет, в котором мы добавляем столбец описания раздела для целей сортировки. Для визуальной помощи я хотел бы иметь возможность назначать цвет для каждого описания раздела.

Поток:

  1. Запустить отчет
  2. Добавлены описания разделов
  3. Запустите макрос, чтобы назначить уникальные цвета для каждого раздела

Проблема, с которой я столкнулся, заключается в том, что каждый раз, когда мы запускаем отчет, может быть добавлено другое количество описаний разделов. Поэтому я не уверен, как назначать уникальные цвета, когда может быть от 3 секций до 20 разделов.

Моя общая идея такова:

(a) Удалите все условное форматирование из столбца A)

  1. Просмотрите столбец A (где описаны описания) и найдите все уникальные значения
  2. Вставить уникальные значения в отдельный лист
  3. Пройдите через каждое уникальное значение и назначьте цвет из группы цветов
  4. Назначьте условный формат столбцу A на моем основном листе на основе присвоений с шага 3

Другой способ, которым это можно было бы сделать, - это запустить этот процесс каждый раз, когда значение будет изменено в столбце A.

Что касается цветовой библиотеки, может быть приятно иметь более нейтральные цвета, которые торчат. Мне не нужны яркие неоновые зелени и тому подобное.

Любая помощь будет принята с благодарностью!

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$2:$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

Так что сейчас это работает, и я получаю все свои уникальные значения, и я могу успешно пройти цикл и остановиться, когда я доберусь до последнего значения. Следующим шагом будет замена...

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

... после Do, для создания условного форматирования с использованием информации из списка.

Замена будет использовать что-то вроде:

Sheets("Grid").Select
Columns("A:A").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
 Formula1:="='STORED VALUES'!$F$2"
' $F$2 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

Я думаю, что я рядом, но у меня просто проблемы с петлей. Как только цикл работает, я хотел бы иметь возможность изменять цвета, которые также используются.

Конечной целью является то, что после запуска макроса каждое значение в столбце A в моем листе сетки будет иметь условный формат, основанный на уникальных значениях в столбце A.

2 ответа

Я решил не делать градиентную вещь и вместо этого использовать функцию, которая генерирует случайные значения цвета. Это используется с параметрами Interior.ColorIndex а не с длинными цветами.

Это должно помочь вам начать:

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


Спасибо Дэвиду за вашу помощь. Я решил решить проблему, найдя цвета, которые мне нравились, и убедился, что я использовал только эти цвета. Я попытался назначить случайные цвета, но это было невозможно. Этот метод принимает только несколько цветов и назначает их через мои дескрипторы.

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 = ********
 .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$2:$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

licensed under cc by-sa 3.0 with attribution.