fill color in columns if date range is within specified quarter/year

[janboo]

Hello,
Thanks in advance for your help! I am looking for vba macro to help highlight a range of cells within the quarter/year columns if date value falls within baseline start and baseline end?

If the type is equal to tree, to high the quarter/year cells with color green​

If the type is equal to bush, to high the quarter/year cells with color orange​

If the type is equal to ground, to high the quarter/year cells with color blue​

Sincerely grateful for your help!
Jan

 

[Kenneth Hobson]

IF just a few types, conditional formatting formulas could do it. I guess I would use a macro if more than 5 types. If you attached the short example file, we could help more easily. Click the Attach files button below a reply box.

 

[janboo]

Thanks much Kenneth! There is a possibility that the types can grow to more 5.

 

[Kenneth Hobson]

I will workup a solution in VBA then. I prefer that myself.

While I work on it, think about, is this a one time run to update all or automate it to do the whole row if any of the 3 key cells in that row change values. The latter would probably be my preference. In that way, it would act sort of like conditional formatting.

 

[Kenneth Hobson]

I attached the file but for those that don't want to open it:

1. Create a worksheet named Types.
2. In a column, put names of each the type.
3. In column to right of each type, set the fill color.
4. Select the type cells and name the range, Types.
5. Right click the sheets tab, View Code, and paste the code below.
6. Change any of the 3 key cells in a row to trigger the worksheet event.
a. It is expected that the start date will always be less than or equal to the end date.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, rQ As Range, rw As Range, c As Range, rn As Long
  Dim d As Object, bd As Date, ed As Date, md As Date
  Dim yq As String, fc As Range, tc As Long

  Set r = Intersect(Target, Range("B2", Cells(Rows.Count, "B").End(xlUp)).Resize(, 3))
  If r Is Nothing Then Exit Sub
  Set rQ = Range("E1", Range("E1").End(xlToRight))
  Set d = CreateObject("Scripting.Dictionary")

  For Each rw In r.Rows
    rn = rw.Row
    bd = Cells(rn, "C") 'Begin/Start Date
    md = bd                 'Month Date Increment
    ed = Cells(rn, "D") 'End Date
    d.RemoveAll             'RemoveAll dictionary object element values

    Do While md < ed
      yq = Year(md) & " Q" & WorksheetFunction.RoundUp(Month(md) / 3, 0) 'YYYY Q#
      If Not d.exists(yq) Then d.Add yq, Nothing
      md = DateAdd("m", 1, md)
    Loop
 
    rQ.Offset(rn - 1).Interior.Color = xlNone
    Set fc = Worksheets("Types").Range("Types").Find(Cells(rw.Row, "B").Value)
    If fc Is Nothing Then GoTo NextRW
    tc = fc.Offset(, 1).Interior.Color

    For Each c In rQ
        If d.exists(c.Value) Then c.Offset(rn - 1).Interior.Color = tc
    Next c
NextRW:
  Next rw

  Set d = Nothing
End Sub

 

[janboo]

You are a genius and a lifesaver Kenneth!!! Thank you sincerely for taking the time in solving his so quickly for me!!
Grateful!
Jan