Change row color based on a date in one cell

capncaveman · Jul 13, 2011

What I would like to do is have a spreadsheet with our online orders and keep track of when the orders go beyond a certain date.

For instance. I have all the order information on one row. One of these cells will be an order date. I would like to have that whole row green within one week of the order date and then turn yellow from 1 week to 2 weeks and turn red beyond 2 weeks from the order date. The order dates will always be different so the formula will have to go off of the order date...not the current date.

I would also like to have a cell with a check box or a cell where I can enter "Shipped" and it will then turn the row back to white.

Is this possible? I am using Excel 2007

Any help would be appreciated!!

repairman615 · Jul 13, 2011

Hello,

Welcome to the board!!

Shortcut keys --> Alt+F11 to open VBEditor
Keystrokes --> Alt - I - M to insert Standard Module
Paste in the below code
Within the VBeditor press F5 to run
Or
Close the VBEditor, Shortcut Keys ALT+F8 to run
This code may be called by other means including assingning to a button

Sub ShipDate() Dim cell As Range, _ fC As String, _ lC As String, _ dC As String, _ dR As Long fC = "A" ''' Change to first Column with data, colors will start here lC = "F" ''' Change to last Column with data, colors will end here dC = "C" ''' Change to Column with date dR = 2 ''' Change to first row of date in above Column For Each cell In Range(dC & dR & ":" & dC & Range(dC & Rows.Count).End(xlUp).Row) If UCase(cell.Offset(0, 3).Value) <> "SHIPPED" Then If cell.Value < Date - 14 Then 'cell.Offset(0, 1).Value = "Here 14" Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 30, 0) ElseIf cell.Value < Date - 7 Then 'cell.Offset(0, 1).Value = "Here 7" Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 220, 0) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 220, 30) End If Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Pattern = xlNone End If Next cell End Sub

Change the commented places to your values.

Does that help?

-Jeff

repairman615 · Jul 13, 2011

Be sure to test on a copy.

repairman615 · Jul 13, 2011

I forgot to mention this uses a column for marking as shipped.

Here is an update to specify the column for this.

Sub ShipDate() Dim cell As Range, _ fC As String, _ lC As String, _ dC As String, _ dR As Long, _ ShC As Long fC = "A" ''' Change to first Column with data, colors will start here lC = "F" ''' Change to last Column with data, colors will end here dC = "C" ''' Change to Column with date dR = 2 ''' Change to first row of date in above Column ShC = 3 '''Enter Cell offset for the shipped column. _ (Start at date Column, count columns until Shipped column) _ (Positive to the right, Negative to the left) For Each cell In Range(dC & dR & ":" & dC & Range(dC & Rows.Count).End(xlUp).Row) If UCase(cell.Offset(0, ShC).Value) <> "SHIPPED" Then If cell.Value < Date - 14 Then 'cell.Offset(0, 1).Value = "Here 14" Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 30, 0) ElseIf cell.Value < Date - 7 Then 'cell.Offset(0, 1).Value = "Here 7" Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 220, 0) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 220, 30) End If Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Pattern = xlNone End If Next cell End Sub

Excel 2007<table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th><th>B</th><th>C</th><th>D</th><th>E</th><th>F</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">order date</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;">7/13/2011</td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;"></td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;">7/10/2011</td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;"></td><td style="text-align: right;background-color: #00DC1E;;"></td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style="text-align: right;background-color: #DCDC00;;"></td><td style="text-align: right;background-color: #DCDC00;;"></td><td style="text-align: right;background-color: #DCDC00;;">7/5/2011</td><td style="background-color: #DCDC00;;">Here 7</td><td style="text-align: right;background-color: #DCDC00;;"></td><td style="text-align: right;background-color: #DCDC00;;"></td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;">7/1/2011</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Shipped</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;">6/25/2011</td><td style="background-color: #DC1E00;;">Here 14</td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;"></td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;">6/15/2011</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">Shipped</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;">6/6/2011</td><td style="background-color: #DC1E00;;">Here 14</td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;"></td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;">6/29/2011</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style=";">shipped</td></tr><tr ><td style="color: #161120;text-align: center;">10</td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;">6/28/2011</td><td style="background-color: #DC1E00;;">Here 14</td><td style="text-align: right;background-color: #DC1E00;;"></td><td style="text-align: right;background-color: #DC1E00;;"></td></tr><tr ><td style="color: #161120;text-align: center;">11</td><td style="text-align: right;background-color: #DCDC00;;"></td><td style="text-align: right;background-color: #DCDC00;;"></td><td style="text-align: right;background-color: #DCDC00;;">6/30/2011</td><td style="background-color: #DCDC00;;">Here 7</td><td style="text-align: right;background-color: #DCDC00;;"></td><td style="text-align: right;background-color: #DCDC00;;"></td></tr></tbody></table>Sheet1

capncaveman · Jul 13, 2011

Hey! Thanks for the quick response!!!

I am very green at Excel but I managed to make a couple of changes but I am having trouble fine tuning this code. Since I dont know VB that poses kind of a problem lol.

There will be times where I will have to skip rows and not enter a date to accommodate multiple back ordered items per order. When this happens the code seems to want those lines red with no data in the date cell. I have no clue how to fix that.

Also I changed the first row with a date to 5 and it made 3 lines red and one green above row 5. Row 1 and 2 were white and rows 3 and 4 were orange. Again I have no idea why. Thank you again for your help.

The file I am working with can be found below
http://www.toolhouseinc.com/media/test.xlsm

capncaveman · Jul 13, 2011

Oh yeah...the ones where there is no date and the line is red, they need to be the same color as the order above.

repairman615 · Jul 13, 2011

Hello,

Clear any colors you may have in the first 5 rows.

Replace the old code with the below and then test to see if it works as you would like.

I did make the 'undated' row a different color.

Here is the code:

 Sub ShipDate() Dim cell As Range, _ fC As String, _ lC As String, _ dC As String, _ dR As Long, _ ShC As Long fC = "A" ''' Change to first Column with data, colors will start here lC = "L" ''' Change to last Column with data, colors will end here dC = "B" ''' Change to Column with date dR = 5 ''' Change to first row of date in above Column ShC = 10 '''Enter Cell offset for the shipped column. _ (Start at date Column, count columns until Shipped column) _ (Positive to the right, Negative to the left) For Each cell In Range(dC & dR & ":" & dC & Range(dC & Rows.Count).End(xlUp).Row) 'MsgBox cell.Value = "" If UCase(cell.Offset(0, ShC).Value) <> "SHIPPED" And cell.Value <> "" Then If cell.Value < Date - 14 Then 'cell.Offset(0, 1).Value = "Here 14" Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 30, 0) ElseIf cell.Value < Date - 7 Then 'cell.Offset(0, 1).Value = "Here 7" Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(230, 230, 0) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 220, 30) End If Else If cell.Value = "" Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 240, 180) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Pattern = xlNone End If End If Next cell End Sub

Let me know how this does for you.

-Jeff

capncaveman · Jul 14, 2011

It works perfect! I dont know how you do this stuff! Thanks a million!!!

Say for instance if you have 5 rows with dates and they are colored their respective colors. When you delete the data from all 5 of them...which will happen in my case, the data is deleted but only the top row turns back to white and the remaining rows stay the color that they were changed to based on the date. Do I have to just highlight those and say no fill or is it even possible to add to the VB code?

repairman615 · Jul 15, 2011

Hello,

Every bit of VBA knowledge I have has came from mrexcel site.

It takes some time, but helping others has proven to be the best way to really learn.

I have came up with a way to delete all of your data in the form and leave it blank down to the headers. What I have done is to use two buttons along the top and assigned these two macros to them.

Here is what I am using:

Sub ShipDate() Dim cell As Range, _ fC As String, _ lC As String, _ dC As String, _ dR As Long, _ ShC As Long fC = "A" ''' Change to first Column with data, colors will start here lC = "L" ''' Change to last Column with data, colors will end here dC = "B" ''' Change to Column with date dR = 5 ''' Change to first row of date in above Column ShC = 10 '''Enter Cell offset for the shipped column. _ (Start at date Column, count columns until Shipped column) _ (Positive to the right, Negative to the left) For Each cell In Range(dC & dR & ":" & dC & Range(dC & Rows.Count).End(xlUp).Row) If UCase(cell.Offset(0, ShC).Value) <> "SHIPPED" And cell.Value <> "" Then If cell.Value < Date - 14 Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 30, 0) ElseIf cell.Value < Date - 7 Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(230, 230, 0) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 220, 30) End If Else If cell.Value = "" Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 240, 180) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Pattern = xlNone End If End If Next cell End Sub Sub ClearData() Dim cell As Range, _ dC As String, _ dR As Long, _ fC As String, _ lC As String, _ dCR As Long fC = "A" ''' Change to first Column with data, colors will start here lC = "L" ''' Change to last Column with data, colors will end here dC = "B" ''' Change to Column with date dR = 5 ''' Change to first row of date in above Column If MsgBox("This action will clear all data entries within form." & vbNewLine & _ "Continue?", vbYesNo, "Delete all Data???") = vbYes Then If Range(dC & Rows.Count).End(xlUp).Row < 5 Then dCR = 5 Else dCR = Range(dC & Rows.Count).End(xlUp).Row End If For Each cell In Range(dC & dR & ":" & dC & dCR) 'Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Pattern = xlNone Range(fC & cell.Row & ":" & lC & cell.Row).Clear Next cell Else Exit Sub End If End Sub

Also I have tried to take the automation a step further for you in hopes of receiving a Fein MM top plus.

Right click the sheet tab
Select veiw code

Paste in the below code
Private Sub Worksheet_Change(ByVal Target As Range) Dim changed As Range, _ cell As Range, _ fC As String, _ lC As String, _ dC As String, _ dR As Long, _ ShC As Long fC = "A" ''' Change to first Column with data, colors will start here lC = "L" ''' Change to last Column with data, colors will end here dC = "B" ''' Change to Column with date dR = 5 ''' Change to first row of date in above Column ShC = 10 '''Enter Cell offset for the shipped column. _ (Start at date Column, count columns until Shipped column) _ (Positive to the right, Negative to the left) Set changed = Intersect(Target, Range("B5:B" & Range("B" & Rows.Count).End(xlUp).Row)) If Target.Cells.Count > 1 Then Exit Sub If Not changed Is Nothing Then For Each cell In Range(dC & dR & ":" & dC & Range(dC & Rows.Count).End(xlUp).Row) If UCase(cell.Offset(0, ShC).Value) <> "SHIPPED" And cell.Value <> "" Then If cell.Value < Date - 14 Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(220, 30, 0) ElseIf cell.Value < Date - 7 Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(230, 230, 0) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 220, 30) End If Else If cell.Value = "" Then Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Color = RGB(0, 240, 180) Else Range(fC & cell.Row & ":" & lC & cell.Row).Interior.Pattern = xlNone End If End If Next cell End If End Sub 

It is basically the same as the other, only this should be triggered by any entry in the date column.

-Jeff

GlennUK · Jul 15, 2011

All lovely bits of code, but can I ask a question .... why not use Conditional Formatting for this?

Excel Workbook

A

B

C

D

E

F

1

order date

2

13/07/2011

3

10/07/2011

4

05/07/2011

5

01/07/2011

Shipped

6

25/06/2011

7

15/06/2011

Shipped

8

06/06/2011

9

29/06/2011

shipped

10

28/06/2011

11

30/06/2011

Sheet1

... formatted using:
selection of A2:F11
... condition 1
formula:=$F2="Shipped"
format:no format
stop if true: ticked

condition 2
formula:=$C2<(TODAY()-14)
format:fill red
stop if true: ticked

condition 3
formula:=$C2<(TODAY()-7)
format: fill yellow
stop if true: ticked

condition 4
formula:=$C2>=(TODAY()-7)
format: fill green
stop if true: ticked

Change row color based on a date in one cell

capncaveman

New Member

Excel Facts

repairman615

Well-known Member

repairman615

Well-known Member

repairman615

Well-known Member

capncaveman

New Member

capncaveman

New Member

repairman615

Well-known Member

capncaveman

New Member

repairman615

Well-known Member

GlennUK

Well-known Member

Similar threads

Forum statistics

Share this page

Change row color based on a date in one cell

New Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

New Member

New Member

Well-known Member

New Member

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock