Microsoft 365 Excel - effacer des lignes des 3 derniers jours de mois + insérer des lignes

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
     Dim Nf$, Liste, Continuer As Boolean, i As Long, _
         DateDéb As Date, Nbjours As Byte, Dates(), Nr As Long
     Dim Lo As ListObject
     Liste = [_Tb_Ouvriers]
     Nf = Sh.Name
     Continuer = False
    
     For i = 1 To UBound(Liste, 1)
          If Liste(i, 4) = Nf Then Continuer = True: Exit For
     Next
     If Not Continuer Then Exit Sub
     Select Case Target.Address
          Case Sh.[_Mois].Address, Sh.[_Année].Address
          Case Sh.[_Nom].Address
               Sh.Name = [_Nom]: Continuer = False
          Case Else
          Continuer = False
     End Select
     If Not Continuer Then Exit Sub   
    
     DateDéb = DateValue("1 " & [_Mois] & " " & [_Année])
     Nbjours = CLng(WorksheetFunction.EoMonth(DateDéb, 0)) - CLng(DateDéb) + 1
     ReDim Dates(0 To Nbjours - 1)
     For i = 0 To Nbjours - 1
          Dates(i) = CLng(DateDéb) + i
     Next
    
     Set Lo = Sh.ListObjects(1)   
     With Lo
          Application.ScreenUpdating = False
          Application.EnableEvents = False
          Nr = .ListRows.Count
          If Nr > Nbjours Then .ListRows(Nr).Range.Offset(Nbjours - Nr + 1).Resize(Nr - Nbjours).Clear
          .ListColumns(2).DataBodyRange.ClearContents
          .Resize .Range.Resize(Nbjours)
          .ListColumns(2).DataBodyRange.Value = WorksheetFunction.Transpose(Dates)
          Application.EnableEvents = True
          Application.ScreenUpdating = True
     End With 
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)    
     Dim Nf$, Liste, Continuer As Boolean, i As Long, lgn As Long, Lr As Long, Rép
     Dim Lo As ListObject
     Liste = [_Tb_Ouvriers]
     Nf = Sh.Name
     Continuer = False
    
     For i = 1 To UBound(Liste, 1)
          If Liste(i, 4) = Nf Then Continuer = True: Exit For
     Next
     If Not Continuer Then Exit Sub
    
     Set Lo = Sh.ListObjects(1)
     If Intersect(Target, Lo.ListColumns(2).Range) Is Nothing Then Exit Sub
    
     Cancel = True
     lgn = Target.Row
     Rép = MsgBox("Insérer une ligne " & Format(Target.Value, "dddd d mmmm yyyy") & " sous cette ligne ?", vbYesNo, Nf)
     If Rép = vbNo Then Exit Sub
     Lr = Target.Row - Lo.Range.Row + 1
     Lo.ListRows.Add Lr + 1
     Intersect(Sh.Rows(lgn + 1), Lo.ListColumns(2).Range).Value = Target.Value    
End Sub