Цвет фона ячейки на основе предустановки для этого значения в другом диапазоне

Question

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

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

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

Option Explicit

Sub colorrange()


Dim hCell As Range
Dim qCell As Range
Dim rMedewerkers As Range
Dim rKleuren As Range
Dim lastRow As Range

'find last row
Set lastRow = Range("A5").End(xlDown)

Set rKleuren = ThisWorkbook.Sheets("kleuren_medewerkers").Range("A1:A100")

Set rMedewerkers = Range(Range("I5"), ActiveSheet.Cells(lastRow.Row, 10))


For Each qCell In rKleuren
    For Each hCell In rMedewerkers
        If hCell.Value = qCell.Value Then
            hCell.Interior.ColorIndex = qCell.Interior.ColorIndex
        End If

     Next
Next

End Sub

PS Я нашел это решение на SO, но я думаю, что это можно сделать с гораздо меньшим количеством кода и циклов

Answer 1

Я обнаружил свою глупую ошибку.

Не используйте ColorIndex, а Color; Это добилось цели. По всей видимости, ColorIndex имеет только 56 доступных цветов.

Option Explicit

Sub colorrange()


Dim hCell As Range
Dim qCell As Range
Dim rMedewerkers As Range
Dim rKleuren As Range
Dim lastRow As Range

'find last row
Set lastRow = Range("A5").End(xlDown)

Set rKleuren = ThisWorkbook.Sheets("kleuren_medewerkers").Range("A1:A100")

Set rMedewerkers = Range(Range("I5"), ActiveSheet.Cells(lastRow.Row, 10))


For Each qCell In rKleuren
    For Each hCell In rMedewerkers
        If hCell.Value = qCell.Value Then
            hCell.Interior.Color= qCell.Interior.Color
        End If

     Next
Next

End Sub

Answer 2

Это функция, которая лежит в основе решения, которое я sh предлагаю вам. Эта функция предполагает, что цвет каждой найденной ячейки связан с именем, которое находится в самой ячейке.

Функция CellColor (ключ ByVal как вариант) As Long '002

Dim LookUpRange As Range
Dim Fnd As Range

With Worksheets("kleuren_medewerkers")
    ' pls check if this range really starts in row 1
    Set LookUpRange = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Set Fnd = LookUpRange.Find(Key, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not Fnd Is Nothing Then CellColor = Fnd.Interior.Color

End Функция

Здесь представлена ​​замена кода, который вы запускаете при загрузке книги. Вынимает полный слой петель. Поэтому это намного эффективнее. Однако, что заставило меня написать этот код, так это нестабильность вашего собственного кода из-за вашей обработки ActiveSheet. Вы указываете это в некоторых случаях и подразумеваете это в других. Возможно, вы никогда не сильно меняете лист, но если вы когда-нибудь примете, вас могут ждать сюрпризы. Вы можете вызвать эту процедуру из события Open.

Sub SetRangeColors()
    ' 002

    Dim Cell As Range
    Dim Medewerkers As Range
    Dim Col As Long

    ' better declare the sheet by name (!)
    '   especially if you run the proc on Workbook_Open
    With ActiveSheet
        Set Medewerkers = .Range(.Cells(5, "I"), .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 9))

        For Each Cell In Medewerkers
            Col = CellColor(Cell.Value)
            ' do nothing if .Value isn't listed
            If Col Then Cell.Interior.Color = Col
         Next Cell
    End With
End Sub

Ваш лист небольшой, и обновление при открытии - незначительный вопрос, но большинство заданных вами цветов уже есть. Поэтому большая часть работы является излишней. Если вы установите процедуру события, описанную ниже, в листе кодов рабочего листа, в котором вы указываете, цвет ячейки диапазона Medewerkers будет изменен на месте по мере ввода имен, и вам может больше не потребоваться ежедневное общее обновление.

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 002

    Dim Medewerkers As Range
    Dim Col As Long

    ' no need to declare the sheet here because
    '   the sheet is specified by the code's location
    Set Medewerkers = Range(Cells(5, "I"), Cells(Rows.Count, "A").End(xlUp).Offset(0, 9))

    If Not Application.Intersect(Medewerkers, Target) Is Nothing Then
        With Target
            If .Cells.CountLarge = 1 Then
                Col = CellColor(.Value)
                ' do nothing if .Value isn't listed
                If Col Then .Interior.Color = Col
            End If
        End With
    End If
End Sub