Наступна рутинна програма Excel VBA та допоміжні функції надають функціональність для виділення декількох рядків на основі груп чисел у першому стовпчику діапазону даних, що є інакше досяжним лише при умовному форматуванні. Будь-яка кількість стовпців і рядків може бути обрана, хоча я не перевіряв продуктивність на великих таблицях.
Код є простим, пробираючи клітинки у вибраному діапазоні та застосовуючи новий колір, коли значення в першому стовпці змінюється, коли програма рухається вниз по діапазону.
Схема вибору кольору є дуже базовою. Кольори, рівновіддалені в спектрі, підтримуваному Excel (2007+), вибираються виходячи з кількості різних кольорів, встановлених у програмі (наразі 16), а потім присвоюються випадковим чином групуванням рядків у таблиці даних.
Для темних кольорів цифри або текст у клітинках встановлюються білим кольором для контрасту.
Дві допоміжні функції надають коду кольору заповнення та кольорів шрифту до основного розпорядку.
Sub ColorSortedRange()
' Set the fill color of rows in a selected range based on the values
' in the first column of the range.
Dim Rng As Range, Rng2 As Range
Dim Cell_ As Range
Dim PriorCellValue As Variant
Dim CellColor As Long, FontColorIdx As Long
Dim NumberOfColors As Long
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set Rng = Selection
NumberOfColors = 16 '####### SET NUMBER OF COLORS HERE #######
For Each Cell_ In Rng.columns(1).Cells
If Cell_.Value <> PriorCellValue Then
CellColor = GetColorNumber(NumberOfColors)
FontColorIdx = GetFontColorIndex(CellColor) '
End If
Set Rng2 = Range(Cell_, Cell_.Offset(0, Rng.columns.Count - 1))
With Rng2
With .Interior
.Color = CellColor
.TintAndShade = 0.5 '####### SET TINTING AND SHADING HERE #######
End With
.Font.ColorIndex = FontColorIdx
End With
PriorCellValue = Cell_.Value
Next
With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Function GetColorNumber(NumberOfColors As Long) As Long
' Returns a color number randomly chosen from the number of
' colors specified. This function will not work in Excel versions
' prior to 2007, because of limits on the number of available
' colors.
Dim Step As Long
Dim NumberOfExcelColors As Long
NumberOfExcelColors = 16276000 'approximately
Step = Fix(NumberOfExcelColors / NumberOfColors)
GetColorNumber = WorksheetFunction.RandBetween(1, NumberOfColors) * Step
' The Randbetween function is from the Excel Analysis ToolPak. If it is
' unavailable the following formula can be substituted:
' =INT((upperbound - lowerbound + 1) * RAND() + lowerbound)
End Function
Function GetFontColorIndex(BackgroundColor As Long) As Integer
' Returns color index for dark grey or white, which the function selects
' to contrast with the cell fill color.
Dim R As Long, G As Long, B As Long
Dim FontThreshold As Double
Dim Brightness As Double
R = BackgroundColor Mod 256
G = (BackgroundColor \ 256) Mod 256
B = (BackgroundColor \ 256 \ 256) Mod 256
FontThreshold = 130
Brightness = Sqr(R * R * 0.241 + G * G * 0.691 + B * B * 0.068)
If Brightness < FontThreshold Then
GetFontColorIndex = 2 'white
Else
GetFontColorIndex = 49 'dark (1 is black)
End If
' Long decimal to RGB color conversion algorithm published by Siddharth Rout
' at http://social.msdn.microsoft.com/Forums/en/exceldev/thread/df8a1e1e-e974
' -4a9c-938a-da18ae9f5252. The formula for perceived brightness of RGB colors
' is available in various forms on the Internet, perhaps earliest at
' http://alienryderflex.com/hsp.html.
End Function
