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
attention à ne pas faire Suppr sur la totalité d'un tableau, ça le supprimerait)
