Index / Match cell color with VBA

[zankzank]

Dear all,
I looked at previous posts to see if this questions had already been answered, but I had no luck.
I have a workbook with two sheets
Basically, each time a department in Sheet1.Range("E2:E" & LastRow) matches a department found in Sheet2.Range("A2:A" & LastRow), then cells in range Sheet1.Range("A2:A" & LastRow) will be colored according to the color codes in Sheet2.Range("B2:B" & LastRow).
I have fortunately managed to find a way to color the stages' duration based on the colors in Sheet1.Range("A2:A" & LastRow) :D

I do not seem to find a way to attach the whole (marco-enabled) workbook, so I am attaching pictures instead.
Thanks in advance for any feedback / help!
Best,
S

 

[DanteAmor]

Hi @zankzank , I hope yor are well.

Try this macro:

Sub Cell_Color()
  Dim sh1 As Worksheet
  Dim f As Range, c As Range, d As Range
  Dim i As Long, j As Long, lc As Long
  Dim theColor As Double
  Dim lbl As Boolean
  
  Set sh1 = Sheets("Sheet1")
  With sh1.Range("F2", sh1.Cells(Rows.Count, Columns.Count))
    .ClearContents
    .Interior.Color = xlNone
    sh1.Range("A2:A" & Rows.Count).Interior.Color = xlNone
  End With
  lc = sh1.Cells(1, Columns.Count).End(1).Column
    
  For i = 2 To sh1.Range("E" & Rows.Count).End(3).Row
    Set c = sh1.Range("C" & i)
    Set d = sh1.Range("D" & i)
    If c.Value <> "" And d.Value <> "" And IsDate(c.Value) And IsDate(d.Value) And c.Value <= d.Value Then
      
      Set f = Sheets("Sheet2").Range("A:A").Find(sh1.Range("E" & i).Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        theColor = f.Offset(, 1).Interior.Color
        lbl = False
        sh1.Range("A" & i).Interior.Color = theColor
        For j = 6 To lc
          If (sh1.Cells(1, j).Value >= c.Value And sh1.Cells(1, j).Value <= d.Value) Or _
             (c.Value >= sh1.Cells(1, j).Value And c.Value < sh1.Cells(1, j + 1).Value) Then
            sh1.Cells(i, j).Interior.Color = theColor
            If lbl = False Then
              sh1.Cells(i, j).Value = sh1.Range("B" & i).Value
              lbl = True
            End If
          End If
        Next
      End If
    End If
  Next
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[zankzank]

Hi @zankzank , I hope yor are well.

Try this macro:

Sub Cell_Color()
  Dim sh1 As Worksheet
  Dim f As Range
  Dim i As Long, j As Long, lc As Long
  Dim theColor As Double
  Dim lbl As Boolean
 
  Set sh1 = Sheets("Sheet1")
  With sh1.Range("F2", sh1.Cells(Rows.Count, Columns.Count))
    .ClearContents
    .Interior.Color = xlNone
    sh1.Range("A2:A" & Rows.Count).Interior.Color = xlNone
  End With
  lc = sh1.Cells(1, Columns.Count).End(1).Column
   
  For i = 2 To sh1.Range("E" & Rows.Count).End(3).Row
    'Validations
    If sh1.Range("C" & i).Value <> "" And sh1.Range("D" & i).Value <> "" Then
      If IsDate(sh1.Range("C" & i).Value) And IsDate(sh1.Range("D" & i).Value) Then
     
        If sh1.Range("C" & i).Value <= sh1.Range("D" & i).Value Then
          'search Dept
          Set f = Sheets("Sheet2").Range("A:A").Find(sh1.Range("E" & i).Value, , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            theColor = f.Offset(, 1).Interior.Color
            lbl = False
            sh1.Range("A" & i).Interior.Color = theColor
            For j = 6 To lc
              If (sh1.Cells(1, j).Value >= sh1.Range("C" & i).Value And _
                  sh1.Cells(1, j).Value <= sh1.Range("D" & i).Value) Or _
                 (sh1.Range("C" & i).Value >= sh1.Cells(1, j).Value And _
                  sh1.Range("C" & i).Value < sh1.Cells(1, j + 1).Value) Then
                sh1.Cells(i, j).Interior.Color = theColor
                If lbl = False Then
                  sh1.Cells(i, j).Value = sh1.Range("B" & i).Value
                  lbl = True
                End If
              End If
            Next
          End If
        End If
      End If
    End If
  Next
 
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

Hi @DanteAmor !
First and foremost I wanted to thank you for your time and for your kindness.
I wanted you to know that I copied/pasted your code in my module and it works like a charm!
Now I'll have to spend some "quality time" trying to figure out the code itself :D
Thank you again for your help: I really, really appreciate it!
Best,
S