Apply background fill color to a range based on cell value

[mikenelena]

We use alternating background fill color in columns A-G as a visual reference to distinguish between rows with certain payroll date values stored in G. Currently, we have 2 macro buttons that each apply 1 of the colors. I'd like to incorporate this functionality into the vba language, so we can eliminate another manual task, and clean up the appearance by removing 2 buttons.

I struggled for a while, but finally decided that the solution might lie in the unique numeric codes assigned to dates by Excel. If we subtract the current payroll date from a known, and constant first payroll date, then divide by 2, we will get alternating odd and even numbers, which I figured could serve as the logic for determining which color to apply.

But how to weave that logic into the code?? It seems everything I read wants to push us towards conditional formatting. For a lot of reasons, I don't want to get involved with conditional formatting. I am looking for an automated VBA solution to this.

Many thanks to anyone who can lend a hand!

If it helps, the two colors are:
.ThemeColor = xlThemeColorAccent1.TintAndShade = 0.799981688894314

and

.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314

Sub Copy_PasteDataToMainTab()

Dim LR As LongDim ws As Worksheet, ws1 As Worksheet

Set ws = Worksheets("Query2")Set ws1 = Worksheets("Main")

ws1.Activate

LR = ws.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False

ws.Activate            

Range("A2:G2" & LR).Copy      ws1.Range("A" & Rows.Count).End(3)(2).PasteSpecial 

Paste:=xlPasteValuesAndNumberFormats  '----> Copies values and number formats only to Main starting in Column A
ws1.Activate

Application.ScreenUpdating = TrueApplication.CutCopyMode = FalseRange("D1").Select
End Sub

 

[rlv01]

I'm confused now. In your earlier post you have LR declared as a Long. If LR was changed to a string type (i.e. LR = "$a$1:$a$10"), then no wonder you got an 'Range' of object'_worksheet' failed error for this line of code

Set rng = WS.Range("A1:A" & LR)

 

[mikenelena]

Rick Rothstein wrote:

Change these values to the ColorIndex values you want to use to color the rows.

Rick, this is great. It works, and very quickly, even through 20k+ rows. Many thanks! If you'll indulge me a couple of follow up questions...

The standard interior color index is a little hard on the eyes. Is it possible to use a more muted palette such as we see produced with this combination? I tried to tinker, but these did not seem to play nicely with your code. (Could easily have been my fault though.)

.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314

Also, I'm curious about the resizing. What is the function of that language in the code?

[COLOR=#333333][FONT=monospace]Cells(R, "A").Resize(, 7).Interior.ColorIndex = Cells(R - 1, "G").Interior.ColorIndex    Else      Cells(R, "A").Resize(, 7).Interior.ColorIndex = [/FONT][/COLOR][B][COLOR=#FF0000]59[/COLOR] - Cells(R - 1, "A").Interior.ColorIndex[/B]

Thanks again,
...Mike

 

[mikenelena]

rlv01,

I'm afraid I don't know enough to offer any insight on that.

Rick offered something of a different approach. It works nicely, but I'm hoping to find a way to select sightly more muted colors.

Very grateful to both of you!

...Mike

 

[Rick Rothstein]

The standard interior color index is a little hard on the eyes. Is it possible to use a more muted palette such as we see produced with this combination? I tried to tinker, but these did not seem to play nicely with your code. (Could easily have been my fault though.)

.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314

Interestingly, I liked the colors I chose over the ones you asked for; however, you are the "boss", so here is code to implement your color request...

[table="width: 500"]
[tr]
	[td]Sub AlternateColoring()
  Dim R As Long
  On Error GoTo Whoops
  Application.ScreenUpdating = False
  Range("A2:G2").Interior.ThemeColor = xlThemeColorAccent1
  For R = 3 To Cells(Rows.Count, "G").End(xlUp).Row
    With Cells(R, "A").Resize(, 7)
      .Interior.TintAndShade = 0.799981688894314
      If Cells(R, "G").Value = Cells(R - 1, "G").Value Then
        .Interior.ThemeColor = .Offset(-1).Interior.ThemeColor
      Else
        .Interior.ThemeColor = xlThemeColorAccent1 + xlThemeColorAccent3 - .Offset(-1).Interior.ThemeColor
      End If
    End With
  Next
Whoops:
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

Also, I'm curious about the resizing. What is the function of that language in the code?

[COLOR=#333333][FONT=monospace]Cells(R, "A").Resize(, 7).Interior.ColorIndex = Cells(R - 1, "G").Interior.ColorIndex    Else      Cells(R, "A").Resize(, 7).Interior.ColorIndex = [/FONT][/COLOR][B][COLOR=#FF0000]59[/COLOR] - Cells(R - 1, "A").Interior.ColorIndex[/B]

Resize changes the size of the referenced range.. Given that, Cells(R,"A") is a single cell (if R were, say, 5, then it would be equivalent to cell A5).... Cells(R,"A").Resize(,7) changes the referenced range to A5:G5. The Resize property has two arguments... the first argument is the number of rows to change the reference to and the second argumen is the number of columns to change the reference to. If you omit an argument (as I did with the first argument), then that argument defaults to the number of rows or columns (depending on which was omitted) in the original range.

 

[Zenwood]

This code will highlight like items in column "G" in groups - the color changes when the value in "G" changes.

Public Blue_ As Integer
Public BlueNew_ As Integer
Public ColumnEnd_ As String
Public ColumnStart_ As String
Public Compare_ As String
Public Green_ As Integer
Public GreenNew_ As Integer
Public PageName_ As String
Public Red_ As Integer
Public RedBase_ As Integer
Public RedNew_ As Integer
Public Row_ As Integer
Public WorksheetName_ As String


Sub Highlighter()


Zenwood 2018


'    **************** change this area to suit your needs ****************
Compare_ = "G" '     the column to compare in
Row_ = 2 ' the row to start with
ColumnStart_ = "A" ' start coloring acroos from this row
ColumnEnd_ = "G" ' end coloring across at thia row
WorksheetName_ = "Highlight100.xlsm" '  full name of worksheet
PageName_ = "Work Area" ' name of page
'    *************************************************************


Red_ = 220 '    set red
Green_ = 240 '  set green
Blue_ = 220 ' set blue


RedNew_ = -10
GreenNew_ = -10
BlueNew_ = -10


'If RedNew_ < 1 Then RedNew_ = 1
RedBase_ = Red_


Windows(WorksheetName_).Activate
Sheets(PageName_).Select


Call ColorLoop '    ----------------------------------------


End Sub


Function ColorLoop()


          Do While (Cells(Row_, Compare_) <> "")
          
                    If (Cells(Row_, Compare_) <> "") And (Cells(Row_ - 1, Compare_) = Cells(Row_, Compare_)) Then
                    Red_ = Red_
                    Else
                    
                              If Red_ = RedBase_ Then
                              Red_ = Red_ + RedNew_
                              Green_ = Green_ + GreenNew_
                              Blue_ = Blue_ + BlueNew_
                              
                              Else
                              Red_ = Red_ - RedNew_
                              Green_ = Green_ - GreenNew_
                              Blue_ = Blue_ - BlueNew_
                              End If
                    
                    End If
          
               Range(ColumnStart_ & Row_, ColumnEnd_ & Row_).Interior.Color = RGB(Red_, Green_, Blue_)
         
          Row_ = Row_ + 1


          Loop


End Function

 

[mikenelena]

Rick Rothstein wrote:

Interestingly, I liked the colors I chose over the ones you asked for

Rick, no doubt, my colors were hideous. But I found that it was because there was some mixup in how they were being applied with the tint. I moved a few lines around, and finally got it the way I wanted. Here is what my amended version of your code looks like.

You will note that I called another routine called "Borders". For some reason, the code worked flawlessly on all data that previously existing in the sheet, but stripped away the cell borders from the newest incoming data. I had to add a separate routine to fix that. If anyone knows why the code is stripping away those borders, I'd love to simply the code and eliminate my band-aide solution.

Thanks again to all!

Sub RowColor()
  Dim R As Long
  On Error GoTo Whoops
  Application.ScreenUpdating = False
  
    With Range("A2:G2")
        .Interior.ThemeColor = xlThemeColorAccent1
        .Interior.TintAndShade = 0.799981688894314
    End With
  
For R = 3 To Cells(Rows.Count, "G").End(xlUp).Row
    
    With Cells(R, "A").Resize(, 7)
      .Interior.ThemeColor = xlThemeColorAccent1
      .Interior.TintAndShade = 0.799981688894314
        
        If Cells(R, "G").Value = Cells(R - 1, "G").Value Then
            .Interior.ThemeColor = .Offset(-1).Interior.ThemeColor
            .Interior.TintAndShade = 0.799981688894314
              
        Else
            .Interior.ThemeColor = xlThemeColorAccent1 + xlThemeColorAccent3 - .Offset(-1).Interior.ThemeColor
            .Interior.TintAndShade = 0.799981688894314
        
        End If
    End With
  Next


Call Borders


Whoops:
  Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

finally got it the way I wanted. Here is what my amended version of your code looks like.

You will note that I called another routine called "Borders". For some reason, the code worked flawlessly on all data that previously existing in the sheet, but stripped away the cell borders from the newest incoming data. I had to add a separate routine to fix that. If anyone knows why the code is stripping away those borders, I'd love to simply the code and eliminate my band-aide solution.

I see nothing in my code that should be deleting existing borders.