Question : Interior Colour

I have the code below that worksand is used on another part of the workbook. But what I would like to be able to do is now do the same but if the destination cell interior colour is either yellow or red then only the font is entered.

On the attached file the BRIO Paths is the MASTER and this information is required to be transferred onto the Path Constraints sheet.
So the Colours on the Master are transferred onto the Paths sheet but not when the destination sheet already has an interior colour.

On the attached sheet for Wed I manually created the colours as how I would like to have them applied.

Is this possible ?

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:



'   Format QRNational Maroon
For Each c In rngClr1
'For Each c In ActiveSheet.UsedRange
    ' check for yellow
    If c.Interior.ColorIndex = 9 Then
        shtJIL.Activate
        
'        Cells((c.Row * 2) + 6, (c.Column * 2) + 16).ClearContents
        Cells((c.Row * 2) + 6, (c.Column * 2) + 18).Interior.ColorIndex = 9
        Cells((c.Row * 2) + 6, (c.Column * 2) + 18).Font.ColorIndex = 2
        Cells((c.Row * 2) + 6, (c.Column * 2) + 18).Font.Bold = True


        msJIL.Activate
'        c.ClearContents
'        c.Interior.ColorIndex = xlNone
    End If
Next

'   Format Pacific National Purple
For Each c In rngClr1
'For Each c In ActiveSheet.UsedRange
    ' check for yellow
    If c.Interior.ColorIndex = 13 Then
        shtJIL.Activate
        
'        Cells((c.Row * 2) + 6, (c.Column * 2) + 16).ClearContents
        Cells((c.Row * 2) + 6, (c.Column * 2) + 18).Interior.ColorIndex = 13
        Cells((c.Row * 2) + 6, (c.Column * 2) + 18).Font.ColorIndex = 2
        Cells((c.Row * 2) + 6, (c.Column * 2) + 18).Font.Bold = True

        msJIL.Activate
'        c.ClearContents
'        c.Interior.ColorIndex = xlNone
    End If
Next

Attachments:

interior-colour-test.xls (78 KB) (File Type Details)

interior colour test

Answer : Interior Colour

Try this.

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:



Option Explicit

Public Sub ApplyBRIO()
  Dim wksFrom As Worksheet
  Dim wksTo As Worksheet
  Dim rngFrom As Range
  Dim rngTo As Range
  Dim c As Range
  Dim lngColArea As Long
  Set wksFrom = Worksheets("BRIO Paths x JIL")
  Set wksTo = Worksheets("Path Constraints ex JIL")
  Application.ScreenUpdating = False
  For Each c In wksFrom.Range("B1:O1")
    If c.NumberFormat Like "ddd *" Then
      If rngFrom Is Nothing Then
        Set rngFrom = wksFrom.Range(c.Cells(3, 1), wksFrom.Cells(62, c.Column))
      Else
        Set rngFrom = Union(rngFrom, wksFrom.Range(c.Cells(3, 1), wksFrom.Cells(62, c.Column)))
      End If
    End If
  Next
  Set rngTo = wksTo.Range("B3:H62")
  For lngColArea = 1 To rngFrom.Areas.Count
    For Each c In rngFrom.Areas(lngColArea).Cells
      If Len(Trim(c.Value)) <> 0 Then
        Select Case rngTo.Cells(c.Row - 2, lngColArea).Interior.Color
          Case vbYellow, vbRed
            'just transfer the text
            rngTo.Cells(c.Row - 2, lngColArea).Value = c.Value
          Case Else
            'transfer both text and interior color
            rngTo.Cells(c.Row - 2, lngColArea).Value = c.Value
            rngTo.Cells(c.Row - 2, lngColArea).Interior.Color = c.Interior.Color
            rngTo.Cells(c.Row - 2, lngColArea).Font.Color = c.Font.Color
        End Select
        'Stop
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub