Column color fill

[rjplante]

I have a table (see table below) and I have a row that has 5 dates in 5 consecutive columns. There is a blank row between each set of data. I have five months of columns, each month a block of five columns. I would like to have a macro that would start at column G and check to see if Date 1 fits the case for that column (30 days divided by 5 = 6, so Case 1 = Date <6). If date 1 fits case 1, then add the date to the cell and change to color based on the color matrix. If the date in the date 1 column does not fit the case for column G, move one cell to the right and see if date 1 fits into that date range. and loop through the remaining cells until it reaches the end of the last month. When Date 1 is done, loop through the cells for Date 2, etc, through Date 5. Then I need it to skip the blank row and repeat the process for each row with data in it.

I have included a set of date numbers that correspond to the month in the top row, located in the cells below the table. I was thinking that this might be helpful in solving the date checking component. I have worked out a way to do this, but I use a large If then statement to do just one month for one date. Doing it this way would be very slow and tedious as well as take up a lot of code. I know there has to be a more elegant way to write the code than what I have.


Here is what I have started with. NOTE: The cell references are off because I have created a more simplified table the my original.
My VBA Code:

Dim VATDate As Date

VATDate = CDate(Range("J" & ActiveCell.Row))

If Month(VATDate) = Range("BG3").Value Then

    If Day(VATDate) <= 6 Then
    
        Range("R" & ActiveCell.Row).Interior.Color = RGB(255, 230, 150)
        Range("R" & ActiveCell.Row).Value = Range("J" & ActiveCell.Row).Value
        Range("S" & ActiveCell.Row).Select
        
    ElseIf Day(VATDate) > 6 And Day(VATDate) <= 12 Then
    
        Range("S" & ActiveCell.Row).Interior.Color = RGB(255, 230, 150)
        Range("S" & ActiveCell.Row).Value = Range("J" & ActiveCell.Row).Value
        Range("T" & ActiveCell.Row).Select
    
    ElseIf Day(VATDate) > 12 And Day(VATDate) <= 18 Then
    
        Range("T" & ActiveCell.Row).Interior.Color = RGB(255, 230, 150)
        Range("T" & ActiveCell.Row).Value = Range("J" & ActiveCell.Row).Value
        Range("U" & ActiveCell.Row).Select
    
    ElseIf Day(VATDate) > 18 And Day(VATDate) <= 24 Then
    
        Range("U" & ActiveCell.Row).Interior.Color = RGB(255, 230, 150)
        Range("U" & ActiveCell.Row).Value = Range("J" & ActiveCell.Row).Value
        Range("V" & ActiveCell.Row).Select
    
    ElseIf Day(VATDate) > 24 Then
    
        Range("V" & ActiveCell.Row).Interior.Color = RGB(255, 230, 150)
        Range("V" & ActiveCell.Row).Value = Range("J" & ActiveCell.Row).Value
        Range("W" & ActiveCell.Row).Select
    
    End If

End If

Data Table:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1	Date 1	Date 2	Date 3	Date 4	Date 5	Display Data	May					June					July					August					September
2
3	1-Jun-2020	19-Jun-2020	26-Jun-2020	2-May-2020	1-Jul-2020
4
5	13-Jul-2020	25-Jul-2020	4-Aug-2020	13-Aug-2020	20-Aug-2020
6
7	1-Aug-2020	15-Aug-2020	22-Aug-2020	6-Sep-2020	11-Sep-2020
8
9
10
11
12							Case 1	Case 2	Case 3	Case 4	Case 5
13					Case 1	Date < 6
14					Case 2	Date > 6 AND Date <= 12											Color	R	G	B
15					Case 3	Date > 12 AND Date <= 18										Date 1		255	250	150
16					Case 4	Date > 18 AND Date <= 24										Date 2		215	240	200
17					Case 5	Date > 24										Date 3		255	215	215
18																Date 4		200	215	240
19																Date 5		255	220	255
20
21						Month Numbers	5	6	7	8	9
Sheet1

Cell Formulas
Range	Formula
G1	G1	=TEXT(TODAY(),"mmmm")
L1	L1	=TEXT(EDATE(TODAY(),BA1+1),"mmmm")
Q1	Q1	=TEXT(EDATE(TODAY(),BA1+2),"mmmm")
V1	V1	=TEXT(EDATE(TODAY(),BA1+3),"mmmm")
AA1	AA1	=TEXT(EDATE(TODAY(),BA1+4),"mmmm")
C3	C3	=IF(OR(B3="",B3="TBD"),"",B3+7)
G21	G21	=MONTH(TODAY())
H21:K21	H21	=G21+1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
E3	Expression	=$C3="Bob"	text	NO
E3	Expression	=$C3="Bob"	text	NO
E3	Expression	=$C3="Andrew"	text	NO
E3	Expression	=$C3="Amber"	text	NO
E3	Expression	=$C3="Robert"	text	NO
E3	Expression	=$C3="Andrew"	text	NO
E3	Expression	=$C3="Amber"	text	NO
A3:E10	Expression	=$C3="Bob"	text	NO
A3:E10	Expression	=$C3="Bob"	text	NO
A3:E10	Expression	=$C3="Andrew"	text	NO
A3:E10	Expression	=$C3="Amber"	text	NO
A3:E10	Expression	=$C3="Robert"	text	NO
A3:E10	Expression	=$C3="Andrew"	text	NO
A3:E10	Expression	=$C3="Amber"	text	NO

Thanks for the help.

 

[DanteAmor]

Dante Amor
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	Date 1	Date 2	Date 3	Date 4	Date 5	Display Data	may					jun					jul
2
3	01/jun/2020	19/jun/2020	26/jun/2020	02/may/2020	01/jul/2020	Bob	Bob					Bob			Bob	Bob	Bob
4
5	13/jul/2020	02/jul/2020	04/ago/2020	13/ago/2020	20/ago/2020	Amor											Amor		Amor
6
7	01/ago/2020	15/ago/2020	22/ago/2020	06/sep/2020	11/sep/2020	Andrew
8
Hoja4

The macro works considering your example, just like the example above.
- The abbreviated name of the month (May, Jun, Jul, etc.), will be searched in row 1.
- The day of the month will be divided by 6 to obtain only 5 weeks per month.
- The color will be obtained from cells A1 to E1.
Try the following:

Sub Column_color_fill()
  Dim lr As Long, c  As Range, f As Range, m As String, n As Long
  
  lr = Range("A" & Rows.Count).End(3).Row
  Range("G3:BZ" & lr).ClearContents
  Range("G3:BZ" & lr).Interior.Color = xlNone
  
  For Each c In Range("A3:E" & lr).SpecialCells(xlCellTypeConstants)
    m = MonthName(Month(c.Value), True)
    n = WorksheetFunction.RoundUp(Day(c.Value) / 6, 0) - 1
    If n > 4 Then n = 4
    Set f = Rows(1).Find(m, , xlValues, xlWhole)
    If Not f Is Nothing Then
      With Cells(c.Row, f.Column + n)
        .Value = Cells(c.Row, "F")
        .Interior.Color = Cells(1, c.Column).Interior.Color
      End With
    End If
  Next
End Sub

 

[rjplante]

Dante,

My apologies as I did not fill in the table the way I wanted it displayed. I have included the updated table below. I believe it may modify your code when you see the output results I am looking for. I wanted the day and month (dd-mmm) in the colored cell. If there is a date in that column, I want the date in the correct month column with the cell colored. If there is no date, no color in the calendar section.


Updated Table:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1	Date 1	Date 2	Date 3	Date 4	Date 5	Display Data	May					June					July					August					September
2
3	1-Jun-2020	19-Jun-2020	26-Jun-2020	2-May-2020	1-Jul-2020		2-May					1-Jun		19-Jun		26-Jun	1-Jul
4
5	13-Jul-2020	25-Jul-2020	4-Aug-2020	13-Aug-2020	20-Aug-2020									13-Jul							25-Jul	3-Aug		13-Aug	20-Aug
6
7	1-Aug-2020	15-Aug-2020	22-Aug-2020		11-Sep-2020																	1-Aug		15-Aug	22-Aug			11-Sep
8
9
10
Sheet1

Cell Formulas
Range	Formula
G1	G1	=TEXT(TODAY(),"mmmm")
L1	L1	=TEXT(EDATE(TODAY(),BA1+1),"mmmm")
Q1	Q1	=TEXT(EDATE(TODAY(),BA1+2),"mmmm")
V1	V1	=TEXT(EDATE(TODAY(),BA1+3),"mmmm")
AA1	AA1	=TEXT(EDATE(TODAY(),BA1+4),"mmmm")
C3	C3	=IF(OR(B3="",B3="TBD"),"",B3+7)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
E3	Expression	=$C3="Bob"	text	NO
E3	Expression	=$C3="Bob"	text	NO
E3	Expression	=$C3="Andrew"	text	NO
E3	Expression	=$C3="Amber"	text	NO
E3	Expression	=$C3="Robert"	text	NO
E3	Expression	=$C3="Andrew"	text	NO
E3	Expression	=$C3="Amber"	text	NO
A3:E10	Expression	=$C3="Bob"	text	NO
A3:E10	Expression	=$C3="Bob"	text	NO
A3:E10	Expression	=$C3="Andrew"	text	NO
A3:E10	Expression	=$C3="Amber"	text	NO
A3:E10	Expression	=$C3="Robert"	text	NO
A3:E10	Expression	=$C3="Andrew"	text	NO
A3:E10	Expression	=$C3="Amber"	text	NO

 

[rjplante]

Try this link.

Dropbox

www.dropbox.com

 

[rjplante]

Sorry that was for someone else, I got confused and posted it here.

 

[DanteAmor]

I wanted the day and month (dd-mmm) in the colored cell.

Try this

Sub Column_color_fill()
  Dim lr As Long, c As Range, f As Range, m As String, n As Long
  
  lr = Range("A" & Rows.Count).End(3).Row
  Range("G3:BZ" & lr).ClearContents
  Range("G3:BZ" & lr).Interior.Color = xlNone
  
  For Each c In Range("A3:E" & lr).SpecialCells(xlCellTypeConstants)
    m = MonthName(Month(c.Value))
    n = WorksheetFunction.RoundUp(Day(c.Value) / 6, 0) - 1
    If n > 4 Then n = 4
    Set f = Rows(1).Find(m, , xlValues, xlWhole)
    If Not f Is Nothing Then
      With Cells(c.Row, f.Column + n)
        .Value = c.Value
        .Interior.Color = Cells(1, c.Column).Interior.Color
      End With
    End If
  Next
End Sub

 

[rjplante]

In my table, I only have five months displayed, starting with the month the matches today. When I run your code it fills in a couple of cells, but they are off of the table with the dates in them. Then the macro crashes on the line "m = MonthName(Month(c.Value), True)" with the error "Run-Time error '13': Type mismatch." I don't know why this is happening, nor how to fix it.

 

[DanteAmor]

in the range of cells in row 3 and down and in columns A through E, only dates should exist.

 

[DanteAmor]

To validate dates in the range of columns A to E.
Try this,

Sub Column_color_fill()
  Dim lr As Long, c As Range, f As Range, m As String, n As Long
  
  lr = Range("A" & Rows.Count).End(3).Row
  Range("G3:BZ" & lr).ClearContents
  Range("G3:BZ" & lr).Interior.Color = xlNone
  
  For Each c In Range("A3:E" & lr).SpecialCells(xlCellTypeConstants)
    If c.Value <> "" And IsDate(c.Value) Then
      m = MonthName(Month(c.Value))
      n = WorksheetFunction.RoundUp(Day(c.Value) / 6, 0) - 1
      If n > 4 Then n = 4
      Set f = Rows(1).Find(m, , xlValues, xlWhole)
      If Not f Is Nothing Then
        With Cells(c.Row, f.Column + n)
          .Value = c.Value
          .Interior.Color = Cells(1, c.Column).Interior.Color
        End With
      End If
    End If
  Next
End Sub

 

[rjplante]

Dante,

We are getting close. When I run the code now I get no crashes with any of the code. Thumbs up. On my actual spreadsheet the range I have with all my date in it is (J5:N & lr) The range of cells where I want the dates and color to fill in is from R5:AP105. I have adjusted the code you supplied to reflect these changes. When I run the code. None of the dates appear in the R:AP range of cells. There are cells in the range from BF:BL that do get colored and have the dates put in them. Not all of the dates get added there, but at least some of them do. Also I do not know why it starts at column BF and ends at BL. I have included your code with my range updates below.

Sub Column_color_fill()
  
  
  Dim lr As Long, c  As Range, f As Range, m As String, n As Long
  
  lr = Range("A" & Rows.Count).End(3).Row
  Range("R5:AP" & lr).ClearContents
  Range("R5:AP" & lr).Interior.Color = xlNone
  
  For Each c In Range("J5:N" & lr).SpecialCells(xlCellTypeConstants)
    If c.Value <> "" And IsDate(c.Value) Then
      m = MonthName(Month(c.Value))
      n = WorksheetFunction.RoundUp(Day(c.Value) / 6, 0) - 1
      If n > 4 Then n = 4
      Set f = Rows(1).Find(m, , xlValues, xlWhole)
      If Not f Is Nothing Then
        With Cells(c.Row, f.Column + n)
          .Value = c.Value
          .Interior.Color = Cells(1, c.Column).Interior.Color
        End With
      End If
    End If
  Next
 
End Sub

What do I need to do to get this fixed. Your code is awesome and very few lines to get what I need done. I hope someday to be able to understand the tools you are using to achieve this as it is pretty cool.