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

[GeeWhiz7]

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
	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
2	Start	End	Index	Task	7/1/2022	7/2/2022	7/3/2022	7/4/2022	7/5/2022	7/6/2022	7/7/2022	7/8/2022	7/9/2022	7/10/2022	7/11/2022	7/12/2022	7/13/2022
3	7/1/2022	7/4/2022	4	A
4	7/2/2022	7/9/2022	1	B
5	7/5/2022	7/12/2022	7	C
6	7/9/2022	7/10/2022	2	D
7	7/11/2022	7/23/2022	2	E
8
9	Desired Result
10	Start	End	Index	Task	7/1/2022	7/2/2022	7/3/2022	7/4/2022	7/5/2022	7/6/2022	7/7/2022	7/8/2022	7/9/2022	7/10/2022	7/11/2022	7/12/2022	7/13/2022
11	7/1/2022	7/4/2022	4	A
12	7/2/2022	7/9/2022	1	B
13	7/5/2022	7/12/2022	7	C
14	7/9/2022	7/10/2022	3	D
15	7/11/2022	7/23/2022	5	E
Sheet1

Cell Formulas
Range	Formula
G2,G10	G2	=TODAY()
H2:S2,H10:S10	H2	=G2+1

 

[6StringJazzer]

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.

 

[GeeWhiz7]

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.

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
	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
2	Start	End	Index	Task	7/1/2022	7/2/2022	7/3/2022	7/4/2022	7/5/2022	7/6/2022	7/7/2022	7/8/2022	7/9/2022	7/10/2022	7/11/2022	7/12/2022	7/13/2022
3	7/1/2022	7/4/2022	4	A
4	7/2/2022	7/9/2022	1	B
5	7/5/2022	7/12/2022	7	C
6	7/9/2022	7/10/2022	2	D
7	7/11/2022	7/23/2022	2	E
8
9	Desired Result
10	Start	End	Index	Task	7/1/2022	7/2/2022	7/3/2022	7/4/2022	7/5/2022	7/6/2022	7/7/2022	7/8/2022	7/9/2022	7/10/2022	7/11/2022	7/12/2022	7/13/2022
11	7/1/2022	7/4/2022	4	A
12	7/2/2022	7/9/2022	1	B
13	7/5/2022	7/12/2022	7	C
14	7/9/2022	7/10/2022	3	D
15	7/11/2022	7/23/2022	5	E
Sheet1

Cell Formulas
Range	Formula
G2,G10	G2	=TODAY()
H2:S2,H10:S10	H2	=G2+1

 

[GeeWhiz7]

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.

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
	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
2	Start	End	Index	Task	7/1/2022	7/2/2022	7/3/2022	7/4/2022	7/5/2022	7/6/2022	7/7/2022	7/8/2022	7/9/2022	7/10/2022	7/11/2022	7/12/2022	7/13/2022
3	7/1/2022	7/4/2022	4	A
4	7/2/2022	7/9/2022	1	B
5	7/5/2022	7/12/2022	7	C
6	7/9/2022	7/10/2022	2	D
7	7/11/2022	7/23/2022	2	E
8
9	Desired Result
10	Start	End	Index	Task	7/1/2022	7/2/2022	7/3/2022	7/4/2022	7/5/2022	7/6/2022	7/7/2022	7/8/2022	7/9/2022	7/10/2022	7/11/2022	7/12/2022	7/13/2022
11	7/1/2022	7/4/2022	4	A
12	7/2/2022	7/9/2022	1	B
13	7/5/2022	7/12/2022	7	C
14	7/9/2022	7/10/2022	3	D
15	7/11/2022	7/23/2022	5	E
Sheet1

Cell Formulas
Range	Formula
G2,G10	G2	=TODAY()
H2:S2,H10:S10	H2	=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

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

 

[GeeWhiz7]

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

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.

 

[GeeWhiz7]

Here is the working code that colors by index number defined in column E (5). Changing vTopDate to Varient fixed the issue.
Option Explicit

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