'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