XL 2016 Recopie d'un texte si valeur au croisement de colonne et ligne identique

Option Explicit

Type Années: Y As Integer: B As Integer: End Type

Sub Activités()
  If Not IsDate([P2]) Then Exit Sub
  Dim dcl%: dcl = Cells(6, Columns.Count).End(1).Column: If dcl = 6 Then Exit Sub
  Dim dlg&: dlg = Cells(Rows.Count, 2).End(3).Row: If dlg = 6 Then Exit Sub
  Dim an(1 To 10) As Années, a%, n As Byte, d As Date, m As Byte, j As Byte
  Dim chn$, lig&, v%, c%, i%: a = Year([P2]) - 1: Application.ScreenUpdating = 0
  For i = 7 To dcl
    v = Year(Cells(6, i)): If v <> a Then n = n + 1: a = a + 1: an(n).Y = a: an(n).B = i
  Next i
  With Range([G7], Cells(dlg, dcl)): .ClearContents: .ClearComments: End With
  For lig = 7 To dlg
    With Cells(lig, 2)
      chn = .Value
      If chn <> "" Then
        If IsDate(.Offset(, 1)) Then
          d = .Offset(, 1): a = Year(d)
          For i = 1 To n
            If an(i).Y = a Then
              c = an(i).B: m = Month(d)
              Do While Month(Cells(6, c)) <> m And c <= dcl: c = c + 1: Loop
              If c <= dcl Then
                j = Day(d)
                Do While Day(Cells(6, c)) <> j And c <= dcl: c = c + 1: Loop
                If c <= dcl Then
                  With Cells(lig, c): .AddComment: .Comment.Text chn: End With
                End If
              End If
            End If
          Next i
        End If
      End If
    End With
  Next lig
End Sub