XL 2016 copier toutes les lignes entre janvier et fevrier

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Lo  As ListObject, Nom$
    
     'Tableau actif
     Set Lo = Target.ListObject
     'Si en dehors d'un tableau sortir
     If Lo Is Nothing Or Target.Count > 1 Then Exit Sub
     'Extraction du mois
     Nom = Replace(Lo.Name, "tb_", "")
     'Si le nom n'est pas un mois sortir
     If Not IsDate("1 " & Nom) Then Exit Sub
     'Ajouter une ligne si l'on se trouve sur la dernière
     If Lo.Range.Rows(Lo.Range.Rows.Count).Row = Target.Row And Target <> "" Then Lo.ListRows.Add
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

     'Vérifier que la cible comporte le cellule nommée "Date_Début"
     If Intersect(Target, [Date_Début]) Is Nothing Then Exit Sub
    
     'Remplacer la date par celle du lundi correspondant
     Application.EnableEvents = False
     If IsEmpty([Date_Début]) Then [Date_Début] = Date
     [Date_Début] = [Date_Début] - Weekday([Date_Début], vbMonday) + 1
    
     'Mettre à jour les tableaux
     Màj_Semaine
     Application.EnableEvents = True
    
End Sub

Sub Màj_Semaine()
     Init_Semaine
     Import_Tâches_Mois
End Sub

'Remise à zéro et redimensionnement des tableaux de la feuille "Planificateur Semaine"
Sub Init_Semaine()
     JoursPleins = Array("tb_Lundi", "tb_Mardi", "tb_Mercredi", "tb_Jeudi", "tb_Vendredi")
     JoursRéduits = Array("tb_Samedi", "tb_Dimanche")
    
     Application.ScreenUpdating = False
     Application.EnableEvents = False
    
     'Effacer le contenu des tableaux
     For Each Lo In Sh_Semaine.ListObjects
          With Sh_Semaine.Evaluate(Lo.Name)
               .Columns(1).ClearContents
               .Columns(2).ClearContents
          End With
     Next
     'Dimension initiale des tableaux
     For Each jour In JoursPleins                 '12 lignes
          With Sh_Semaine.Evaluate(jour)
               nb = .Rows.Count
               If nb > 12 Then
                    For i = 13 To nb
                         .ListObject.ListRows(1).Delete
                    Next i
               Else
                    For i = nb + 1 To 12
                         .ListObject.ListRows.Add
                    Next i
               End If
          End With
     Next
     For Each jour In JoursRéduits                '5 lignes
          With Sh_Semaine.Evaluate(jour)
               nb = .Rows.Count
               If nb > 5 Then
                    For i = 6 To nb
                         .ListObject.ListRows(1).Delete
                    Next i
               Else
                    For i = nb + 1 To 5
                         .ListObject.ListRows.Add
                    Next i
               End If
          End With
     Next
     With Sh_Semaine.[tb_Tâches]                  '20 lignes
               nb = .Rows.Count
               If nb > 20 Then
                    For i = 21 To nb
                         .ListObject.ListRows(1).Delete
                    Next i
               Else
                    For i = nb + 1 To 20
                         .ListObject.ListRows.Add
                    Next i
               End If
     End With
     With Sh_Semaine.[tb_Notes]                   '18 lignes
               nb = .Rows.Count
               If nb > 18 Then
                    For i = 19 To nb
                         .ListObject.ListRows(1).Delete
                    Next i
               Else
                    For i = nb + 1 To 18
                         .ListObject.ListRows.Add
                    Next i
               End If
     End With
    
     Application.EnableEvents = True
     Application.ScreenUpdating = True

End Sub

'Importer les tâches non terminées du mois dans la feuille "Planificateur Semaine"
Sub Import_Tâches_Mois()
    
     Dim Lo As ListObject, Nom$, tb, tb_à_faire(), nb%, nbPlus%, jour
     'Liste des jours dont le nombre de lignes peut évoluer
     Jours = Array("tb_Lundi", "tb_Mardi", "tb_Mercredi", "tb_Jeudi", "tb_Vendredi", "tb_Samedi")
     'Mois courant
     Nom = "tb_" & WorksheetFunction.Proper(Format([Date_Début], "mmmm"))
     'Valeurs du tableau du mois courant
     tb = Sh_Mensuel.Evaluate(Nom).Value
    
     'stocker les éléments non terminés
     nb = 0
     For i = 1 To UBound(tb)
          If tb(i, 4) = "" And tb(i, 1) <> "" Then  'si la ligne contient un élément à faire non terminé
               nb = nb + 1: ReDim Preserve tb_à_faire(1 To nb): tb_à_faire(nb) = tb(i, 1)
          End If
     Next
     If nb = 0 Then MsgBox "Aucune tâche planifiée pour le mois de " & Replace(Nom, "tb_", ""): Exit Sub 'Pas d'élément ce mois-ci : sortir
    
     Application.ScreenUpdating = False
     Application.EnableEvents = False
    
     If nb > 20 Then 'Si nb éléments à faire > 20 : redimensionner le tableau des tâches (par un multiple de 3)
          nbPlus = ((nb - 21) \ 3) + 1
          'Ajouter un multiple de 3 lignes au tableau des tâches
          For i = 1 To nbPlus * 3
               Sh_Semaine.ListObjects("tb_Tâches").ListRows.Add
          Next i
          'Ajuster la hauteur des jours de la semaine en conséquence
          For Each N In Jours
               For i = 1 To nbPlus
                    Sh_Semaine.ListObjects(N).ListRows.Add
               Next
          Next N
     End If
     'Ecrire les tâches à faire
     Sh_Semaine.[tb_Tâches].Columns(1).Resize(nb).Value = WorksheetFunction.Transpose(tb_à_faire)
    
     Application.EnableEvents = True
     Application.ScreenUpdating = True
    
End Sub

Sub Effacer_Contenu_Tableau()
    
     Dim Lo As ListObject
     Set Lo = Selection.Cells(1).ListObject
     If Lo Is Nothing Then Exit Sub
     If MsgBox("Effacer le contenu du tableau " & Lo.Name & " ?", vbYesNo) = vbNo Then Exit Sub
    
     Application.ScreenUpdating = False
     Application.EnableEvents = False
     For Each Col In Lo.ListColumns
          Col.Range.ClearContents
     Next
     Application.EnableEvents = True
     Application.ScreenUpdating = True
    
End Sub

Sub Ajouter_Lignes()

     Dim Lo As ListObject
     Set Lo = Selection.Cells(1).ListObject
     If Lo Is Nothing Then Exit Sub
     Application.ScreenUpdating = False
     Application.EnableEvents = False
     For i = 1 To 10
          Lo.ListRows.Add
     Next i
     Application.EnableEvents = True
     Application.ScreenUpdating = True

End Sub