XL 2019 Problème boucle ?

'Dans le module "M01_Remplir_Date_Type"

Option Base 1

Sub Remplir_Date_Type_Dépense(Source As Range)

Dim PlagesMois, Sh_Calendrier As Worksheet, Rg_Mois As Range, Jour As Date
Dim Valeurs, Valeur, Tb(1 To 2) As Byte, i As Integer, j As Integer
    
     Col = Source.Column: Lgn = Source.Row
    
     'Conditions à réunir
     If Source.Count > 1 Then Exit Sub
     If Col > 26 Or Not (Col Mod 4 = 2) Then Exit Sub  'Colonne entre 2 et 26 et  =2 modulo 4
     If Lgn < 33 Or Lgn > 65 Then Exit Sub             'Ligne entre 33 et 65
     'Conditions réunies
    
     'Date du jour dans la colonne à droite de la source
     Jour = Date
     Source.Offset(0, 1).Value = Jour
    
     Set Sh_Calendrier = Feuil1
    
     'Plage occupée par les mois dans la feuille Calendrier
     PlagesMois = Array("B6:H17", "J6:P17", "R6:R17", _
                        "B22:H33", "J22:P33", "R22:R33", _
                        "B38:H49", "J38:P49", "R38:R49", _
                        "B54:H65", "J54:P65", "R54:R65")
    
     'Plage occupée par le mois en cours
     Set Rg_Mois = Sh_Calendrier.Range(PlagesMois(Month(Date)))
     'Valeurs contenue dans Rg_Mois
     Valeurs = Rg_Mois.Value
    
     'Trouver le jour courant
     For i = 1 To UBound(Valeurs, 2)
          For j = 1 To UBound(Valeurs, 1)
               If Valeurs(j, i) = Jour Then
                    'mémoriser les index et sortir de la boucle
                    Tb(1) = j: Tb(2) = i
                    Exit For
               End If
               'Si les index sont mémorisés sortir de la boucle
               If Tb(1) > 0 Then Exit For
          Next j
     Next i
     'Si aucun index Erreur on sort sans rien faire
     If Tb(1) < 1 Or Tb(2) < 1 Then Exit Sub
    
     'Ajout éventuel d'un retour chariot si la valeur de la cellule n'est pas vide
     If Not IsEmpty(Valeurs(Tb(1) + 1, Tb(2))) Then Valeurs(Tb(1) + 1, Tb(2)) = Valeurs(Tb(1) + 1, Tb(2)) & vbCrLf
    
     'Compléter la valeur de la cellule du jour
     Rg_Mois.Cells(Tb(1) + 1, Tb(2)).Value = Valeurs(Tb(1) + 1, Tb(2)) & Source.Value

End Sub

Private Sub worksheet_activate()
    Range("A1").Select
    ScrollArea = "A1:AD65" 'pour bloquer la feuille
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

     Application.EnableEvents = False
     Remplir_Date_Type_Dépense Target
     Application.EnableEvents = True

End Sub

Private Sub worksheet_activate()
    'Range("A1").Select
    Feuil1.ScrollArea = "A1:X65" 'affichage max
'Selection du curseur sur la date du jour
    Dim d As Date, cal As Range, cel As Range
    d = Int(Now())
    Set cal = Range("B5:X65")
For Each cel In cal.Cells
    If cel.Value = d Then cel.Offset(1, 0).Resize(1, 1).Select: Exit For
Next cel
End Sub