CODEWITHSUNDEEP
excelvba
dreojs16
dreojs16

Reputation: 117

Background color of a cell based on a preset for that value in another range

I have a column with a list of employees names that has been colored. Each cell with distinct employee name has a different background color.

I am trying to use this range to color the cells of another range based on the employee name.

This seems to work, but Employees get the wrong color (e.g. should have been green but turns out yellow). This is my code so far:

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

P.S. I have found this solution on SO, but I think it can be done with a lot less code and looping

Upvotes: 0

Views: 42

Answers (2)

Variatus
Variatus

Reputation: 14373

This is the function at the heart of the solution I wish to propose to you. This function presumes that the color of each cell found is associated with the name that is in the cell itself.

Function CellColor(ByVal Key As Variant) 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 Function

Here is a replacement for the code you presently run when you load the workbook. It takes out a complete layer of loops. Therefore it's much more efficient. However, what caused me to write this code is the instability your own code has due to your handling of the ActiveSheet. You specify it in some instances and imply it in others. Perhaps you never change the sheet much but if you ever due you may be in for surprises. You can call this procedure from the Open event.

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

Your sheet is small and doing an update on open is a minor matter but most of the colors you set are already there. Therefore most of the work is redundant. If you install the event procedure below in the code sheet of the worksheet in which you specify the Medewerkers range cell coloring will be changed on the spot, as you enter the names, and you may not need the daily general update anymore.

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

Upvotes: 0

dreojs16
dreojs16

Reputation: 117

I found my dumb mistake.

Do not use ColorIndex but Color; It did the trick. Apperently ColorIndex has only 56 colors available to it. 

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

Upvotes: 1

Related Questions