Как получить цвет по образцам RGB в Экселе при помощи VBA

Необходимое ПО: Микрософт Эксель.
Среда разработки:  VBA.
Задача: по имеющимся образцам цвета RGB (например, 120/120/85) создать палитру данных цветов с 10-ю степенями осветления. Результат будет наподобие этого:

↑ Исходными цветами окрашены клетки первой строки. Далее идут степени осветления.

А для того, чтобы получить такую красоту, тебе необходимо будет заранее приготовить таблицу с образцами каждого цвета: значениями R, G, B:

Зачем?

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

Макрос

Итак, все, что тебе теперь необходимо сделать, это добавить новый макрос в свою книгу Эксель. Сам код представлен ниже:

Option Explicit
Sub ПолучитьОбразцыЦветов()
'
' Макрос1 Макрос
'

'
    Dim rR As Range, cel As Range
    Dim Us As String, Nw As Integer
    Dim R0() As Integer, G0() As Integer, B0() As Integer
    Dim i As Long, k As Long, Countk As Integer
    Dim Rt As Integer, Gt As Integer, Bt As Integer
    Dim lColumnsCnt As Integer
    
    lColumnsCnt = ActiveSheet.Columns.Count
    
    Us = ActiveSheet.Name
    Application.DisplayAlerts = False
    On Error Resume Next
    Set rR = Application.InputBox("Выбери диапазон RGB шириной в 3 колонки:", _
        "Выбор", Type:=8)
    Application.DisplayAlerts = True
    If rR.Columns.Count <> 3 Then
        MsgBox "Выбранный диапазон должен быть шириной = 3 колонки!", _
        vbCritical, "Останавливаю макрос =("
        Exit Sub
    End If
    
    On Error GoTo 0
    
    Countk = rR.Rows.Count
    
    ' на случай, если их слишком много =)
    If Countk > lColumnsCnt Then
        MsgBox "Выбрано слишком много образцов, не могу столько раскрасить", _
        vbCritical, "Останавливаю макрос =("
        Exit Sub
    End If
    
    
    ReDim R0(Countk)
    ReDim G0(Countk)
    ReDim B0(Countk)
    
    'запускаем присвоение базовых цветов
    i = 1
    k = 1
    For Each cel In rR
        Select Case i Mod 3
            Case 1
                If Not IsNumeric(cel) Then
                R0(k) = 255
                Else
                R0(k) = cel
                End If
            Case 2
                If Not IsNumeric(cel) Then
                G0(k) = 255
                Else
                G0(k) = cel
                End If
            Case 0
                If Not IsNumeric(cel) Then
                B0(k) = 255
                Else
                B0(k) = cel
                End If
                k = k + 1
        End Select
        i = i + 1
    Next


    'добавляем новый лист и на нем работаем
    Sheets.Add

    ' подкрасить и написать значения
    For k = 1 To Countk
        Range("A1").Offset(0, k - 1) = R0(k) & "/" & G0(k) & "/" & B0(k)
        Range("A1").Offset(0, k - 1).Interior.Color = RGB(R0(k), G0(k), B0(k))
    Next k
    
    ' редактируем форматирование
    With Range(Cells(1, 1), Cells(1, Countk)).EntireColumn
        .ColumnWidth = 22
    End With
    
    ' запускаем цикл и подкрашиваем клетки внизу в более светлые оттенки
    For k = 1 To Countk
        For i = 1 To 10
            Rt = R0(k) + Int((255 - R0(k)) * i * 0.05)
            Gt = G0(k) + Int((255 - G0(k)) * i * 0.05)
            Bt = B0(k) + Int((255 - B0(k)) * i * 0.05)
            Range("A1").Offset(i, k - 1).Interior.Color = RGB(Rt, Gt, Bt)
            Range("A1").Offset(i, k - 1) = Rt & "/" & Gt & "/" & Bt
        Next i
    Next k
    
End Sub

После всего запускай макрос. Он попросит тебя выбрать диапазон с образцами. После выбора макрос создаст в книге новый лист, куда поместит все выбранные цвета.

В макросе есть недоработки. Если ты их найдешь, сообщи мне, пожалуйста, исправлю!