XL 2016 copier toutes les lignes entre janvier et fevrier

Cybertoto

XLDnaute Nouveau
Bonjour, je cherche une formule VBA pour selectioner toutes les lignes d'une feuille A (echeances mensuelles) entre Janvier et Fevrier exclus, et coller la sélection dans une case d'une feuille B (planing semaine 1 (h4)).
Prendre les lignes de A et coller la valeur dans B.
Le but étant d'affecter un bouton 'import" pour incrémenter les lignes en feuille B.
En soit, c'est pas compliqué, mais la ou ca ne marche plus le simple "copier collé", c'est lorsque je rajoute une ligne ou j'en enlève une, ca ne copie pas tout.
Je vous joint mon fichier
 

Pièces jointes

  • Aide forum.xlsm
    89.6 KB · Affichages: 12

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonsoir à toutes & à tous, bonsoir @Cybertoto

Pour répondre à ta demande j'ai un peu modifier les 2 feuilles non masquées de ton classeurs, principalement en utilisant des tableaux structurés (sans la ligne d'entête ‼️ attention à ne pas faire Suppr sur la totalité d'un tableau, ça le supprimerait)
Ils sont nommés tb_Janvier à tb_Décembre ; tb_Lundi à tb_Dimanche ; tb_Tâches et tb_Notes.

Ceux de la feuille "Echeances Mensuelles" s'étendent automatiquement lors d'une saisie dans la dernière ligne vide (voir l'événement Worksheet_Change de la feuille). Leur dernière colonne sert à marquer les tâches terminées.
Sur cette feuille j'ai placé 2 boutons pour vider un tableau ou pour ajouter 10 lignes d'un coup.

Dans la feuille "Planificateur Semaine" la date de début saisie (>= 03/01/2000) est systématiquement remplacer par le lundi de la même semaine et si elle est effacée, elle est alors remplacée par le lundi de la semaine en cours.
Le changement de date ou le clic sur le bouton "Mise à jour" entraîne la réinitialisation de la feuille avec les tâches non terminées du mois en cours (selon date de début).

Les événements Worksheet_Change des deux feuilles
"Echeances Mensuelles" (sh_Mensuel)
Enrichi (BBcode):
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

"Planificateur Semaine" (sh_Semaine)
Enrichi (BBcode):
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

Module mdl_AtTheOne (les autres macros)
Enrichi (BBcode):
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

Voir le fichier joint
Bon courage
Amicalement
Alain
 

Pièces jointes

  • Aide forum AtTheOne.xlsm
    48 KB · Affichages: 8

Cybertoto

XLDnaute Nouveau
Bonjour @Cybertoto
Pas de nouvelles ...
Est-ce que ma proposition post #2 te conviendrait ?
Une petite réponse s'il te plaît...
Amicalement
Alain
bonjour, merci de toute façon pour le temps accordé a mon problème. Pour ce qui est de la réponse à ma question, je ne m'attendais pas a ca, donc je n'ai pas eu le temps de la mettre en application pour le moment. Comme j'ai pas mal de macros sur mon classeur et 52 onglets ou je dois mettre votre import je n'ai pas eu le temps de la confronter aux autres macro.
Moi je m'attendais juste a une sélection fluctuante qui commençais à un mot clé et s'arrête à un autre.
En tout cas, merci, je vous tiendrai au courant des que j'ai pu la mettre en application.
 

Cybertoto

XLDnaute Nouveau
Bonjour @Cybertoto
Pas de nouvelles ...
Est-ce que ma proposition post #2 te conviendrait ?
Une petite réponse s'il te plaît...
Amicalement
Alain
Bonjour, j'ai eu un peu le temps de m y coller, et il se trouve qu'elle est pas tout à fait compatible avec le reste de mon Excel. La je suis en vacances mais à mon retour je vous transférerai mon Excel. J ai 52 ongalets de semaines et ces dans chaque onglet que je voulait avoir un bouton qui m incrémenté le reste des tâches à faire pour le mois en cours.
Désolé de la réponse tardive.
 

Discussions similaires