Microsoft 365 Report du contenu d'une cellule dans un calendrier

Private Sub Worksheet_Activate()
Dim d As Object, c As Range, tablo, i&, x$, j%, y$
Application.ScreenUpdating = False
'---liste des adresses (pour accélérer)---
On Error Resume Next 'si aucune SpecialCell
Set d = CreateObject("Scripting.Dictionary")
For Each c In [C:I].SpecialCells(xlCellTypeConstants, 1)
    d(c.Value) = c(2).Address
Next
On Error GoTo 0
'---récupération des textes en feuille Apprentissage---
With Sheets("Apprentissage")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("B5:AG" & .Range("A" & .Rows.Count).End(xlUp).Row) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = tablo(i, 1) & " " & tablo(i, 2)
        For j = 4 To 32 Step 4
            If d.exists(tablo(i, j)) Then
                With Range(d(tablo(i, j)))
                    y = .Value
                    If InStr(y, x) = 0 Then .Value = IIf(y = "", "", y & vbLf) & x
                End With
            End If
    Next j, i
End With
End Sub

Private Sub Worksheet_Change(ByVal R As Range)
Dim c As Range, n&, a(), x$
Set R = Intersect(R, [E:E,I:I,M:M,Q:Q,U:U,Y:Y,AC:AC,AG:AG])
If R Is Nothing Then Exit Sub
ReDim a(1 To R.Count, 1 To 2)
For Each c In R
    n = n + 1
    a(n, 1) = c
Next
Application.ScreenUpdating = False
Application.EnableEvents = False
n = 0
Application.Undo 'annule les modifications
For Each c In R
    n = n + 1
    If c <> a(n, 1) Then a(n, 1) = c: a(n, 2) = Cells(c.Row, 2) & " " & Cells(c.Row, 3) Else a(n, 1) = ""
Next
Application.Undo 'rétablit les modifications
Application.EnableEvents = True
With Sheets("Calendrier ") 'espace superflu !!!
    For n = 1 To UBound(a)
        If a(n, 2) <> "" Then
            Set c = .Range("C:I").Find(a(n, 1), , xlFormulas, xlWhole)
            If Not c Is Nothing Then
                x = c(2)
                If InStr(x, a(n, 2)) Then
                    x = Replace(x, vbLf & a(n, 2), "")
                    c(2) = Replace(x, a(n, 2), "")
                End If
            End If
        End If
    Next
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo1, tablo2, i&, j%, c As Range, x$, y$
Set Target = Intersect(Target, [E:E,J3,N3,R3,V3,Z3,AD3,AH3])
If Target Is Nothing Then Exit Sub
If FilterMode Then ShowAllData 'si la feuille est filtrée
tablo1 = Range("B5:AG" & Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Undo 'annule les modifications
tablo2 = Range("B5:AG" & Range("A" & Rows.Count).End(xlUp).Row)
Application.Undo 'rétablit les modifications
Application.EnableEvents = True
With Sheets("Calendrier ") 'espace superflu !!!
    For i = 1 To Application.Min(UBound(tablo1), UBound(tablo2))
        For j = 4 To 32 Step 4
            If tablo1(i, j) <> tablo2(i, j) Then
                Set c = .Range("C:I").Find(tablo2(i, j), , xlFormulas, xlWhole)
                If Not c Is Nothing Then
                    x = c(2)
                    y = tablo2(i, 1) & " " & tablo2(i, 2) & Chr(160) 'texte bordé par le caractère 160
                    If InStr(x, y) Then
                        x = Replace(x, vbLf & y, "")
                        c(2) = Replace(x, y, "")
                    End If
                End If
            End If
    Next j, i
End With
End Sub