heat map calendar

David asks:

Hi, I would like to use this example with my data set however I'd like to visually show the amount of events per date to understand when are we the busiest, slowest, etc. and be able to forecast using this data. Ideally I would like some sort of data bar or color change indicating the level for each date (Jan 1 has 10 items while Jan 2 has 3 and I can visually see that in each cell instead of seeing numbers or a solid color for each cell (here yellow and blue).


I gave him an answer for that post. This post demonstrates how to highlight events in a year and not only a single month. The color shows the amount of events per date.

VBA code

  1. Right click on sheet Calendar
  2. Click "View Code"
    heat map calendar - sheet
  3. Copy vba code below
  4. Paste code to sheet module
  5. Exit VB Editor
Private Sub Worksheet_Activate()
Dim CRng As Variant
Dim Dt As Variant
Dim CDt As Variant
Dim Cnt As Integer
Dim r As Long
Dim c As Long
Dim St As Integer
Application.ScreenUpdating = False
CRng = Worksheets("Calendar").Range("B6:X38").Value
With Worksheets("Table")
    For r = 1 To UBound(CRng, 1)
        For c = 1 To UBound(CRng, 2)
            If CRng(r, c) <> "" Then
                For CDt = 1 To .Range("Table1[Start]").Cells.Count
                    If CRng(r, c) >= Int(.Range("Table1[Start]").Cells(CDt).Value) And CRng(r, c) <= Int(.Range("Table1[End]").Cells(CDt).Value) Then
                        Cnt = Cnt + 1
                    End If
                Next CDt
            End If
        If Cnt > St Then St = Cnt
        Cnt = 0
        Next c
    Next r
End With
Set Rng = Worksheets("Calendar").Range("B6:X38")
    'Remove previous formatting
    With Rng.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Worksheets("Table")
        For Each Dt In Worksheets("Calendar").Range("B6:X38")
            For CDt = 1 To .Range("Table1[Start]").Cells.Count
                If Dt >= Int(.Range("Table1[Start]").Cells(CDt).Value) And Dt <= Int(.Range("Table1[End]").Cells(CDt).Value) Then
                    Cnt = Cnt + 1
                End If
            Next CDt
            If Cnt > 0 Then
            With Dt.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = Worksheets("Calendar").Range("AB5").Interior.Color ' xlThemeColorAccent4 '
                .TintAndShade = 1 - (Cnt / St)
                .PatternTintAndShade = 0
            End With
            'Reset counter a
            Cnt = 0
            End If
        Next Dt
    End With
Application.ScreenUpdating = True
End Sub

Sheet table

heat map calendar - table

Download excel *.xlsm file

Heat map calendar.xlsm