Следующие стандартные и вспомогательные функции 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
