Non Volatile way (macro) to conditionally color cells by date and index

GeeWhiz7

Board Regular
Joined
Nov 22, 2021
Messages
214
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hi,
I have a very large worksheet that has gotten too big and too slow so I am trying to get rid of formatting and volatile functions among other things where possible.
I currently use the built-in conditional formatting to achieve the result mentioned below and would like to find a way to do this in a macro instead.

Goal: Use a macro to conditionally color cells in a timeline based on start date, end date and index # (this part I couldn't do with built-in conditional approach) to start to reduce the tax on my system from a large worksheet with lots of entries, formatting and volatile function use.

Example: Mini-sheet showing blank examples of inputs in a typical sheet and the desired result. The only approach where I have gotten close is to looping through each cell in each row to lookup the offset dates above to color (w/Cell.Interior.ColorIndex) if its dates falls between the Start and End date, but it is really slow to calculate so I'm hoping someone has a more efficient idea.

Thank you

Book2
CDEFGHIJKLMNOPQRS
2StartEndIndexTask7/1/20227/2/20227/3/20227/4/20227/5/20227/6/20227/7/20227/8/20227/9/20227/10/20227/11/20227/12/20227/13/2022
37/1/20227/4/20224A
47/2/20227/9/20221B
57/5/20227/12/20227C
67/9/20227/10/20222D
77/11/20227/23/20222E
8
9Desired Result
10StartEndIndexTask7/1/20227/2/20227/3/20227/4/20227/5/20227/6/20227/7/20227/8/20227/9/20227/10/20227/11/20227/12/20227/13/2022
117/1/20227/4/20224A
127/2/20227/9/20221B
137/5/20227/12/20227C
147/9/20227/10/20223D
157/11/20227/23/20225E
Sheet1
Cell Formulas
RangeFormula
G2,G10G2=TODAY()
H2:S2,H10:S10H2=G2+1
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
I want to make sure your question is clear before I dig in and start writing code.

First
I currently use the built-in conditional formatting to achieve the result mentioned below
but then
this part I couldn't do with built-in conditional approach
So it seems to be a contradiction.


It's clear that you can do this with conditional formatting, using nonvolatile functions. You just need one rule for each color, since a single conditional formatting rule can only specific a single format.

What do you need to do with a macro that is different than what you can do with conditional formatting?

The only thing that I can think of is you don't want to specify a different rule for each color, and you want the code to take care of that for you. But you still need to specify the colors somewhere.

The only approach where I have gotten close is to looping through each cell in each row to lookup the offset dates above to color (w/Cell.Interior.ColorIndex) if its dates falls between the Start and End date, but it is really slow to calculate so I'm hoping someone has a more efficient idea.
That is exactly the way to do it, but please show all your code (I suggest using code tags when you post code, highlight the code then click VBA in the edit controls). There may be a more efficient way to write the code.
 
Upvote 0
I want to make sure your question is clear before I dig in and start writing code.

First

but then

So it seems to be a contradiction.


It's clear that you can do this with conditional formatting, using nonvolatile functions. You just need one rule for each color, since a single conditional formatting rule can only specific a single format.

What do you need to do with a macro that is different than what you can do with conditional formatting?

The only thing that I can think of is you don't want to specify a different rule for each color, and you want the code to take care of that for you. But you still need to specify the colors somewhere.


That is exactly the way to do it, but please show all your code (I suggest using code tags when you post code, highlight the code then click VBA in the edit controls). There may be a more efficient way to write the code.
Hi 6StringJazzer,
Let's see if I can answer your questions well. I currently use the built-in conditional format to format cells between dates by having a single rule/format like you mention which makes a lot of rules and a lot of clicking sometimes. My worksheet is starting to have 1000's of rows and columns and so my goal is to move this formatting to be a choice that can be run as a macro from my userform.

I don't have working code that can do this as I've not figured it out. I've pondered a number of ways, but can't seem to make it go.

Here is what I have that I was working on...if feel like I'm close, but close isn't good enough. Note that I added a new mini-sheet so show how I was trying to use the interior color for items in the task column to color the fill.

VBA Code:
Option Explicit

Sub Recolor()

Dim vCell, vDateStart, vDateEnd, vToColor, vTopDate As Range
Dim vWs As Worksheet
Dim vLocCell
Dim vColor, vRed, vGreen, vBlue As Integer

Set vWs = Sheets("Sheet1")
Set vToColor = vWs.Range("G3:S7")

    For Each vCell In vToColor.Cells
        
        vLocCell = vCell.Address '??? trying to get the address of the cell in current iteration
        
        vColor = Cells(Range(vLocCell.Row), 5).Interior.Color 'pickup the interior color in the current cells row, column 5
        
        vDateStart = Cells(Range(vLocCell).Row, 3).Value ' pickup the start date for current cell row, column 3
        vDateEnd = Cells(Range(vLocCell).Row, 4).Value ' pickup the end date for current cell row, column 4
        
        vTopDate = Cells(2, Range(vLocCell).Column).Value ' pickup the date to match from row 2 in the current cell column
        
            If vTopDate >= vDateStart And vTopDate <= vDateEnd Then
            
                vRed = vColor And 255
                vGreen = vColor \ 256 And 255
                vBlue = vColor \ 256 ^ 2 And 255
                
                With vCell.Interior
                .Pattern = xlSolid
                .Color.RGB = RGB(vRed, vGreen, vBlue)
                .TintAndShade = 0
                .PatternTintAndShad = 0
                End With
                
            End If
            
    Next vCell

End Sub

Book2
CDEFGHIJKLMNOPQRS
2StartEndIndexTask7/1/20227/2/20227/3/20227/4/20227/5/20227/6/20227/7/20227/8/20227/9/20227/10/20227/11/20227/12/20227/13/2022
37/1/20227/4/20224A
47/2/20227/9/20221B
57/5/20227/12/20227C
67/9/20227/10/20222D
77/11/20227/23/20222E
8
9Desired Result
10StartEndIndexTask7/1/20227/2/20227/3/20227/4/20227/5/20227/6/20227/7/20227/8/20227/9/20227/10/20227/11/20227/12/20227/13/2022
117/1/20227/4/20224A
127/2/20227/9/20221B
137/5/20227/12/20227C
147/9/20227/10/20223D
157/11/20227/23/20225E
Sheet1
Cell Formulas
RangeFormula
G2,G10G2=TODAY()
H2:S2,H10:S10H2=G2+1
 
Upvote 0
Hi 6StringJazzer,
Let's see if I can answer your questions well. I currently use the built-in conditional format to format cells between dates by having a single rule/format like you mention which makes a lot of rules and a lot of clicking sometimes. My worksheet is starting to have 1000's of rows and columns and so my goal is to move this formatting to be a choice that can be run as a macro from my userform.

I don't have working code that can do this as I've not figured it out. I've pondered a number of ways, but can't seem to make it go.

Here is what I have that I was working on...if feel like I'm close, but close isn't good enough. Note that I added a new mini-sheet so show how I was trying to use the interior color for items in the task column to color the fill.

VBA Code:
Option Explicit

Sub Recolor()

Dim vCell, vDateStart, vDateEnd, vToColor, vTopDate As Range
Dim vWs As Worksheet
Dim vLocCell
Dim vColor, vRed, vGreen, vBlue As Integer

Set vWs = Sheets("Sheet1")
Set vToColor = vWs.Range("G3:S7")

    For Each vCell In vToColor.Cells
       
        vLocCell = vCell.Address '??? trying to get the address of the cell in current iteration
       
        vColor = Cells(Range(vLocCell.Row), 5).Interior.Color 'pickup the interior color in the current cells row, column 5
       
        vDateStart = Cells(Range(vLocCell).Row, 3).Value ' pickup the start date for current cell row, column 3
        vDateEnd = Cells(Range(vLocCell).Row, 4).Value ' pickup the end date for current cell row, column 4
       
        vTopDate = Cells(2, Range(vLocCell).Column).Value ' pickup the date to match from row 2 in the current cell column
       
            If vTopDate >= vDateStart And vTopDate <= vDateEnd Then
           
                vRed = vColor And 255
                vGreen = vColor \ 256 And 255
                vBlue = vColor \ 256 ^ 2 And 255
               
                With vCell.Interior
                .Pattern = xlSolid
                .Color.RGB = RGB(vRed, vGreen, vBlue)
                .TintAndShade = 0
                .PatternTintAndShad = 0
                End With
               
            End If
           
    Next vCell

End Sub

Book2
CDEFGHIJKLMNOPQRS
2StartEndIndexTask7/1/20227/2/20227/3/20227/4/20227/5/20227/6/20227/7/20227/8/20227/9/20227/10/20227/11/20227/12/20227/13/2022
37/1/20227/4/20224A
47/2/20227/9/20221B
57/5/20227/12/20227C
67/9/20227/10/20222D
77/11/20227/23/20222E
8
9Desired Result
10StartEndIndexTask7/1/20227/2/20227/3/20227/4/20227/5/20227/6/20227/7/20227/8/20227/9/20227/10/20227/11/20227/12/20227/13/2022
117/1/20227/4/20224A
127/2/20227/9/20221B
137/5/20227/12/20227C
147/9/20227/10/20223D
157/11/20227/23/20225E
Sheet1
Cell Formulas
RangeFormula
G2,G10G2=TODAY()
H2:S2,H10:S10H2=G2+1
Some updates to the code...still not quite working but I can assign to the variables up to vTopDate with this so it feels closer

VBA Code:
Option Explicit

Sub Recolor()

Dim vCell, vDateStart, vDateEnd, vToColor, vTopDate As Range
Dim vWs As Worksheet
Dim vLocCell
Dim vColor, vRed, vGreen, vBlue As Integer

Set vWs = Sheets("Sheet1")
Set vToColor = vWs.Range("G3:S7")

    For Each vCell In vToColor.Cells
        
        Set vLocCell = vWs.Range(vCell.Address) '??? trying to get the address of the cell in current iteration
        
        vColor = Cells((vLocCell.Row), 6).Interior.Color 'pickup the interior color in the current cells row, column 6
    
        vDateStart = Cells((vLocCell.Row), 3).Value ' pickup the start date for current cell row, column 3
        vDateEnd = Cells((vLocCell.Row), 4).Value ' pickup the end date for current cell row, column 4
        
        vTopDate = Cells(2, (vCell.Column)).Value ' pickup the date to match from row 2 in the current cell column
        
            If vTopDate >= vDateStart And vTopDate <= vDateEnd Then
            
                vRed = vColor And 255
                vGreen = vColor \ 256 And 255
                vBlue = vColor \ 256 ^ 2 And 255
                
                With vCell.Interior
                .Pattern = xlSolid
                .Color.RGB = RGB(vRed, vGreen, vBlue)
                .TintAndShade = 0
                .PatternTintAndShad = 0
                End With
                
            End If
            
    Next vCell

End Sub
 
Upvote 0
Some updates to the code...still not quite working but I can assign to the variables up to vTopDate with this so it feels closer

VBA Code:
Option Explicit

Sub Recolor()

Dim vCell, vDateStart, vDateEnd, vToColor, vTopDate As Range
Dim vWs As Worksheet
Dim vLocCell
Dim vColor, vRed, vGreen, vBlue As Integer

Set vWs = Sheets("Sheet1")
Set vToColor = vWs.Range("G3:S7")

    For Each vCell In vToColor.Cells
       
        Set vLocCell = vWs.Range(vCell.Address) '??? trying to get the address of the cell in current iteration
       
        vColor = Cells((vLocCell.Row), 6).Interior.Color 'pickup the interior color in the current cells row, column 6
   
        vDateStart = Cells((vLocCell.Row), 3).Value ' pickup the start date for current cell row, column 3
        vDateEnd = Cells((vLocCell.Row), 4).Value ' pickup the end date for current cell row, column 4
       
        vTopDate = Cells(2, (vCell.Column)).Value ' pickup the date to match from row 2 in the current cell column
       
            If vTopDate >= vDateStart And vTopDate <= vDateEnd Then
           
                vRed = vColor And 255
                vGreen = vColor \ 256 And 255
                vBlue = vColor \ 256 ^ 2 And 255
               
                With vCell.Interior
                .Pattern = xlSolid
                .Color.RGB = RGB(vRed, vGreen, vBlue)
                .TintAndShade = 0
                .PatternTintAndShad = 0
                End With
               
            End If
           
    Next vCell

End Sub
Can't figure out why the vTopDate variable wont set, but the ones before it will.
1656696261287.png
 
Upvote 0
Here is the working code that colors by index number defined in column E (5). Changing vTopDate to Varient fixed the issue.
Option Explicit

VBA Code:
Sub Recolor()

Dim vCell, vDateStart, vDateEnd, vToColor As Range
Dim vTopDate As Variant
Dim vWs As Worksheet
Dim vLocCell
Dim vColIndex As Integer

Set vWs = Sheets("Sheet1")
Set vToColor = vWs.Range("G3:S7")

    For Each vCell In vToColor.Cells
       
        Set vLocCell = vWs.Range(vCell.Address) '??? trying to get the address of the cell in current iteration
       
'        vColor = Cells((vLocCell.Row), 6).Interior.Color 'pickup the interior color in the current cells row, column 6
   
        vDateStart = Cells((vLocCell.Row), 3).Value ' pickup the start date for current cell row, column 3
        vDateEnd = Cells((vLocCell.Row), 4).Value ' pickup the end date for current cell row, column 4

        vTopDate = Cells(2, (vCell.Column)).Value ' pickup the date to match from row 2 in the current cell column
        
        vColIndex = Cells((vLocCell.Row), 5).Value
       
            If vTopDate >= vDateStart And vTopDate <= vDateEnd Then
             
                With vCell.Interior
                .Pattern = xlSolid
                .ColorIndex = vColIndex
                .TintAndShade = 0
                End With
               
            End If
           
    Next vCell

End Sub

1656701321225.png
 
Upvote 0
Solution

Forum statistics

Threads
1,224,823
Messages
6,181,170
Members
453,021
Latest member
Justyna P

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