Changing Cell Color Based on Cell Value VBA

A

AndrewMD

New Member
Joined
Jun 1, 2017
Messages
14
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I'm having a difficult time getting this piece of code to work. For a variety of reasons I can't use conditional formatting.

My problem:

Each cell has a different value:

  • GREEN
  • GREENAMBER
  • AMBERGREEN
  • AMBER
  • AMBERRED
  • REDAMBER
  • RED

I simply want something that if the cell says "RED" the code will color that cell red etc. The total population of values is roughly A2:BZ146. The code I have at the moment doesn't cycle through cells properly and every cells ends up colored as whatever color is at the end of the code. I'm just using a test sheet at the moment for the range A1:A7 to try to get it to work.

Code: 
Sub ColourChange()Dim rng As Range
Dim cell As Range


Set rng = Worksheets("RULES").Range("A1:A7")


For Each cell In rng.Cells
 
  If cell.Value = "GREEN" Then
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13561798 'GREEN
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
  ElseIf cell.Value = "GREENAMBER" Then
    With Selection.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 0
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = 13561798 'GREEN
        .TintAndShade = 0
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = 10284031 'AMBER
        .TintAndShade = 0
    End With
    
  ElseIf cell.Value = "AMBERGREEN" Then
      With Selection.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 0
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = 10284031 'AMBER
        .TintAndShade = 0
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = 13561798 'GREEN
        .TintAndShade = 0
    End With
    
  ElseIf cell.Value = "AMBER" Then
       With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10284031 'AMBER
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
  ElseIf cell.Value = "AMBERRED" Then
       With Selection.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 0
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = 10284031 'AMBER
        .TintAndShade = 0
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = 13551615 'RED
        .TintAndShade = 0
    End With
    
  ElseIf cell.Value = "REDAMBER" Then
       With Selection.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 0
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = 13551615 'RED
        .TintAndShade = 0
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = 10284031 'AMBER
        .TintAndShade = 0
    End With
    
  ElseIf cell.Value = "RED" Then
       With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13551615 'RED
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
  End If


Next cell


End Sub

Any ideas? Thanks!
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Sort by date Sort by votes
Seems like the first thing to do is replace "selection.interior" with "cell.interior"

Code: 
Sub ColourChange()
    Dim rng As Range
    Dim cell As Range




    Set rng = Worksheets("Sheet1").Range("A1:A7")


    For Each cell In rng.Cells


        If cell.Value = "GREEN" Then
            With cell.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 13561798                     'GREEN
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With


        ElseIf cell.Value = "GREENAMBER" Then
            With cell.Interior
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                .Gradient.ColorStops.Clear
            End With
            With cell.Interior.Gradient.ColorStops.Add(0)
                .Color = 13561798                     'GREEN
                .TintAndShade = 0
            End With
            With cell.Interior.Gradient.ColorStops.Add(1)
                .Color = 10284031                     'AMBER
                .TintAndShade = 0
            End With


        ElseIf cell.Value = "AMBERGREEN" Then
            With cell.Interior
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                .Gradient.ColorStops.Clear
            End With
            With cell.Interior.Gradient.ColorStops.Add(0)
                .Color = 10284031                     'AMBER
                .TintAndShade = 0
            End With
            With cell.Interior.Gradient.ColorStops.Add(1)
                .Color = 13561798                     'GREEN
                .TintAndShade = 0
            End With


        ElseIf cell.Value = "AMBER" Then
            With cell.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 10284031                     'AMBER
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With


        ElseIf cell.Value = "AMBERRED" Then
            With cell.Interior
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                .Gradient.ColorStops.Clear
            End With
            With cell.Interior.Gradient.ColorStops.Add(0)
                .Color = 10284031                     'AMBER
                .TintAndShade = 0
            End With
            With cell.Interior.Gradient.ColorStops.Add(1)
                .Color = 13551615                     'RED
                .TintAndShade = 0
            End With


        ElseIf cell.Value = "REDAMBER" Then
            With cell.Interior
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                .Gradient.ColorStops.Clear
            End With
            With cell.Interior.Gradient.ColorStops.Add(0)
                .Color = 13551615                     'RED
                .TintAndShade = 0
            End With
            With cell.Interior.Gradient.ColorStops.Add(1)
                .Color = 10284031                     'AMBER
                .TintAndShade = 0
            End With


        ElseIf cell.Value = "RED" Then
            With cell.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 13551615                     'RED
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End If




    Next cell
End Sub
 
Upvote 0
An easy and not very sophisticated way would be to have the color names and colors in a different sheet.
Put the name of the colors in Sheet2 starting at A1
Put the colors of these names beside it in B1 on down
Run this from Sheet1. Change all the references as required.

Code: 
Sub Maybe()
Dim c As Range
For each c in Range("A1:A7")
c.Interior.Color = Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row).Find(c.Value).Offset(, 1).Interior.Color
Next c
End Sub

You could use an array also.
 
Upvote 0
I would do it this way using case:

Just modify the range"

I did two for you.
Just keep adding case statements




Code: 
Sub Fill_My_Colors()
'Modified  11/1/2018  2:14:01 PM  EDT
Dim r As Range
For Each r In Range("A2:A7")
    With r.Interior
    
        Select Case r.Value
   
            Case "Green"
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 13561798 'GREEN
                .TintAndShade = 0
                .PatternTintAndShade = 0
            Case "GREENAMBER"
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                .Gradient.ColorStops.Clear
                .Gradient.ColorStops.Add (0)
                .Color = 13561798
                .TintAndShade = 0
        End Select
    End With
Next
End Sub
 
Upvote 0
As 'My Answer Is This' says, the Select Case structure is a lot cleaner than a continuing succession of ElseIf statements. Also no need to include default properties unless you are changing them.

Code: 
Sub ColourChange()
    Dim rng As Range
    Dim cell As Range
    Set rng = Worksheets("Sheet1").Range("A1:A7")
    For Each cell In rng.Cells
        With cell.Interior
            Select Case cell.Value
            Case "GREEN"
                .Pattern = xlSolid
                .Color = 13561798                     'GREEN
            Case "GREENAMBER"
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                With .Gradient.ColorStops
                    .Clear
                    .Add(0).Color = 13561798          'GREEN
                    .Add(1).Color = 10284031          'AMBER
                End With
            Case "AMBERGREEN"
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                With .Gradient.ColorStops
                    .Clear
                    .Add(0).Color = 10284031          'AMBER
                    .Add(1).Color = 13561798          'GREEN
                End With
            Case "AMBER"
                .Pattern = xlSolid
                .Color = 10284031                     'AMBER
            Case "AMBERRED"
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                With .Gradient.ColorStops
                    .Clear
                    .Add(0).Color = 10284031          'AMBER
                    .Add(1).Color = 13551615          'RED
                End With
            Case "REDAMBER"
                .Pattern = xlPatternLinearGradient
                .Gradient.Degree = 0
                With .Gradient.ColorStops
                    .Clear
                    .Add(0).Color = 13551615          'RED
                    .Add(1).Color = 10284031          'AMBER
                End With
            Case "RED"
                .Pattern = xlSolid
                .Color = 13551615                     'RED
            End Select
        End With
    Next cell
End Sub
 
Upvote 0
If all parameters remain the same you can use case like this.

Code: 
Case "Green", "Green Socks", "Green Hat", "Apple", "Grapes"
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 13561798 'GREEN
                .TintAndShade = 0
                .PatternTintAndShade = 0
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Protecting all cells in a sheet based on .TintAndShade
Replies
4
Views
102
Peter_SSs
Peter_SSs
Z
  • Question Question
=Sum in for Color cells in Column K
Replies
2
Views
194
zone709
Z
J
  • Question Question
Macro to affect cell background color
Replies
3
Views
417
mumps
mumps
K
  • Solved
formating question
Replies
3
Views
324
Micron
M
E
  • Solved
How to Loop through code
Replies
3
Views
299
dreid1011
dreid1011

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top