基于另一个范围中该值的预设的单元格的背景色

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

附言：我在SO上找到了这个解决方案，但我认为它可以用更少的代码和循环来完成

Answer 1

我发现了一个愚蠢的错误。

不要使用ColorIndex，而是使用Color；它成功了。Apprently 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

这是我想向您提出的解决方案的核心功能。此函数假定找到的每个单元格的颜色与单元格本身的名称相关联。

Function CellColor(ByVal Key As Variant(As Long002年

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

终端功能

以下是加载工作簿时当前运行的代码的替换项。它去掉了一层完整的循环。因此，它的效率要高得多。然而，导致我编写此代码的原因是您自己的代码由于处理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