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

 

[KolGuyXcel]

The code that is provided can be more readable with the following.

My assumptions is that the data are in Sheet("Query2") and getting pasted in Sheet("Main").
However, the provided code suggests that it is getting copied from and getting pasted into Sheet("Main"). The only purpose of sheet("Query2") in the code is to determine until which row in Sheet("Main") the data would be copied!

Sub Copy_PasteDataToMainTab()

Dim LR As Long
Dim 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

ws.Range("A2:G" & LR).Copy

ws1.Range("A" & Rows.Count).End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats  '----> Copies values and number formats only to Main starting in Column A

Application.ScreenUpdating = False

ws.Activate

'Range("A2:G" & 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 = True
Application.CutCopyMode = False
Range("D1").Select
End Sub

Now coming to your problem regarding the coloring of the columns, I have a couple of questions.

In which column would we find the "current payroll date"?
What is the constant first payroll date?
In which sheet would the coloring take place?
How are the individual columns (A to G I believe) linked with the logic of odd and even numbers to apply the colors?

 

[mikenelena]

KolGuyXcel,

Thanks for your willingness to help with this!

The payroll date is in "G".
The first payroll date in this file is 1-27-2017. (Not sure the date matters, as long as it stays constant?)
The coloring will happen in "Main".

As for the linking of A-G with the odd/even, my thinking is that Excel will know odd from even based on the date in G. The format is dd-mm-yyyy, but unless I'm wrong, it intrinsically knows the underlying numeric date code number.

When I originally pasted the code, I mistakenly hit the HTML tags instead of code. Maybe I messed something up trying to fix it. Not sure. Anyway, I'm re-posting the code. The data is definitely moving from "Query2" (which is a temporary worksheet in this workbook that holds new payroll data coming in from Access) to "Main". I've cobbled it together over time, so it may not be the cleanest.

Thanks again!

'This copies the current payroll data from the filtered query into the "Main" payroll tab.

Sub Copy_PasteDataToMainTab()


Dim LR As Long
Dim 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 = True
Application.CutCopyMode = False
Range("D1").Select


End Sub

 

[rlv01]

'Alternating row background color
Sub ChangeColorExample()
    Dim WS As Worksheet
    Dim rng As Range
    Dim R As Range

    Set WS = ActiveSheet
    Set rng = WS.Range("A1:A100") '<-- define range as appropriate
    For Each R In rng
        With Application.Intersect(R.EntireRow, WS.Columns("A:G")).Interior
            If R.Row Mod 2 = 0 Then
                .ThemeColor = xlThemeColorAccent1
                .TintAndShade = 0.799981688894314
            Else
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.799981688894314
            End If
        End With
    Next R
End Sub

 

[mikenelena]

rlv01's code gets me close, but there are a couple of issues: The first is that it assigns the colors to every row on an alternating basis. I need to color the rows based on the date in "G". There will be several hundred rows of each date. They should all be the same color.

Also, we have over 20,000 rows, and add several hundred every pay period, so once a color is assigned, it would be best if the code didn't have to run through it all again. I need to add a line of code that will only apply rlv01's code to newly pasted rows coming in from the query.

Finally, for some reason, the code is coloring 5 rows below the data. I double checked to make sure those rows were completely blank. I'd love to understand why it does this. ??

Thanks to everyone trying to help!! Here is rlv01's code with a couple of lines that I added to define the range.

'Alternating row background color
Sub ChangeColorExample()
    Dim WS As Worksheet
    Dim rng As Range
    Dim R As Range
    Dim LR As Long






    Set WS = ActiveSheet
    Set rng = WS.Range("A1:A1" & LR) '<-- define range as appropriate
 
 LR = WS.Cells(Rows.Count, 1).End(xlUp).Row
 
    For Each R In rng
        With Application.Intersect(R.EntireRow, WS.Columns("A:G")).Interior
            If R.Row Mod 2 = 0 Then
                .ThemeColor = xlThemeColorAccent1
                .TintAndShade = 0.799981688894314
            Else
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.799981688894314
            End If
        End With
    Next R
End Sub

 

[rlv01]

Finally, for some reason, the code is coloring 5 rows below the data. I double checked to make sure those rows were completely blank. I'd love to understand why it does this. ??

You probably needed to remove the 2nd "A1" in your range definition

    Set rng = WS.Range("A1:A" & LR) '<-- define range as appropriate

 

[mikenelena]

This throws a Method 'Range' of object'_worksheet' failed error.

Set rng = WS.Range("A1:A" & LR) '<-- define range as appropriate

 

[rlv01]

This throws a Method 'Range' of object'_worksheet' failed error.

What's the value of LR when you get that error?

Sub ThisWorksWithoutError()
    Dim WS As Worksheet
    Dim rng As Range
    Dim LR As Long

    Set WS = ActiveSheet
    LR = 10

    Set rng = WS.Range("A1:A" & LR)
    Debug.Print rng.Address
End Sub

 

[Rick Rothstein]

Assuming Row 1 is a header row, here is code which will alternate colors for Columns "A:G" based on the date (time values are assumed not to be in the cells) in Column G...

[table="width: 500"]
[tr]
	[td]Sub AlternateColoring()
  Dim R As Long
  Range("A2:G2").Interior.ColorIndex = [B][COLOR="#FF0000"]19[/COLOR][/B]
  For R = 3 To Cells(Rows.Count, "G").End(xlUp).Row
    If Cells(R, "G").Value = Cells(R - 1, "G").Value Then
      Cells(R, "A").Resize(, 7).Interior.ColorIndex = Cells(R - 1, "G").Interior.ColorIndex
    Else
      Cells(R, "A").Resize(, 7).Interior.ColorIndex = [B][COLOR="#FF0000"]59[/COLOR][/B] - Cells(R - 1, "A").Interior.ColorIndex
    End If
  Next
End Sub[/td]
[/tr]
[/table]

NOTE: The 19 is the ColorIndex number for Row 2... the 59 is the sum of the two ColorIndex values to be used to color the rows (here, the second ColorIndex is 40). Change these values to the ColorIndex values you want to use to color the rows.

 

[mikenelena]

What's the value of LR when you get that error?

$a$1:$a$10