Voici à quoi j'arrive ... la présentation finale est un poil différente mais l'essentiel est préservé : couleurs, totaux, etc. Cela simplfie (quoique) la macro car je m'appuie sur un tableau croisé dynamique.
Les boutons :
Tu peux créer autant de boutons que tu veux.
Ils seront repris, couleur aussi.
Mets les comme ceci (sauf "Effacer" qu'il faut laisser en l'état)
x : définition
Le "x" que tu choisis peut être important à mon avis demain pour faire des synthèses sur les temps passés par chacun sur chaque activité. Il n'a pas d'effet pour le moment, le tout est d'avoir quelque chose.
S'il y en a plus de 9, il faudrait insérer des lignes avant le tableau de synthèse dans Recap
Les individus :
Ajoute les entre lundi et mardi en insérant des lignes. C'est maintenant possible.
Puis pour les autres jours, insère des lignes et recopie les formules.
J'en ai mis 25...
Les semaines :
C'est déjà bien complexe comme cela. Je préconise (c'est très rare de ma part !) un fichier par semaine. Si tu souhaites, on peut facilement ensuite compiler tous les fichiers et avoir une vue de synthèse mensuelle, voire annuelle.
Les macros :
dans Planning :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Columns.Count = Columns.Count Then Exit Sub
Dim plage As Range
effectif = Application.CountA(Range([Lundi].Offset(1, 0), [Mardi].Offset(-1, 0)))
nbhoraires = Application.CountA(Range("2:2"))
If Not Intersect(Selection, Union([Lundi].Offset(1, 1).Resize(effectif, nbhoraires), [Mardi].Offset(1, 1).Resize(effectif, nbhoraires), [Mercredi].Offset(1, 1).Resize(effectif, nbhoraires), [Jeudi].Offset(1, 1).Resize(effectif, nbhoraires), [Vendredi].Offset(1, 1).Resize(effectif, nbhoraires), [Samedi].Offset(1, 1).Resize(effectif, nbhoraires), [Dimanche].Offset(1, 1).Resize(effectif, nbhoraires))) Is Nothing Then
Set plage = Intersect(Selection, Union([Lundi].Offset(1, 1).Resize(effectif, nbhoraires), [Mardi].Offset(1, 1).Resize(effectif, nbhoraires), [Mercredi].Offset(1, 1).Resize(effectif, nbhoraires), [Jeudi].Offset(1, 1).Resize(effectif, nbhoraires), [Vendredi].Offset(1, 1).Resize(effectif, nbhoraires), [Samedi].Offset(1, 1).Resize(effectif, nbhoraires), [Dimanche].Offset(1, 1).Resize(effectif, nbhoraires)))
plage.Select
choisir True
End If
End Sub
Dans Recap :
Private Sub worksheet_activate()
Dim i%
' Base de données
Dim cel As Range, jour As Date, act, de
If Not Sheets("BdD").ListObjects(1).DataBodyRange Is Nothing Then Sheets("BdD").ListObjects(1).DataBodyRange.Delete
With Sheets("Planning")
nbhoraires = Application.CountA(.Range("2:2"))
For Each cel In .Range([Lundi], .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row))
If nom(cel) <> "" Then
jour = cel
ElseIf cel <> "" Then
act = cel.Offset(0, 1)
de = .Cells(2, cel.Column).Offset(0, 1).Value
For j = cel.Offset(0, 1).Column To cel.Offset(0, 1).Column + nbhoraires
If .Cells(cel.Row, j).Value <> act Then
If act <> "" Then
With Sheets("BdD").ListObjects(1)
.ListRows.Add
.ListColumns("quand").DataBodyRange.Rows(.ListRows.Count).Value = jour
.ListColumns("qui").DataBodyRange.Rows(.ListRows.Count).Value = cel.Value
.ListColumns("de").DataBodyRange.Rows(.ListRows.Count).Value = de
.ListColumns("a").DataBodyRange.Rows(.ListRows.Count).Value = Sheets("Planning").Cells(2, j).Offset(0, -1).Value + 1 / 4 / 24
.ListColumns("quoi").DataBodyRange.Rows(.ListRows.Count).Value = Sheets("Planning").Cells(cel.Row, j).Offset(0, -1).Value
.ListColumns("couleur").DataBodyRange.Rows(.ListRows.Count).Value = Sheets("Planning").Cells(cel.Row, j).Offset(0, -1).Interior.Color
End With
End If
act = .Cells(cel.Row, j)
de = .Cells(2, j)
End If
Next j
End If
Next cel
End With
Sheets("BdD").ListObjects(1).Sort.Apply
' effacement des couleurs
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' Légende ... insérer des lignes avant le TCD en fonctioun, du nombre d'activités possibles
Dim ctrls As Control
i = 1
[C1].CurrentRegion.Clear
For Each ctrls In choix.Controls
If ctrls.Caption <> "Effacer" Then
Cells(i, 3) = Left(ctrls.Caption, InStr(ctrls.Caption, " : ") - 1)
Cells(i, 4) = Mid(ctrls.Caption, InStr(ctrls.Caption, " : ") + 3, 99)
Range(Cells(i, 3), Cells(i, 4)).Interior.Color = ctrls.BackColor
i = i + 1
End If
Next
' plannings individuels
ActiveSheet.PivotTables(1).PivotCache.Refresh
For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
If Cells(i, "E") <> "" And IsNumeric(Cells(i, "E")) Then
Range(Cells(i, "C"), Cells(i, "E")).Interior.Color = Cells(i, "E")
Cells(i, "E").Font.Color = Cells(i, "E")
End If
Next
Range("A1").Select
End Sub
Function nom(cel As Range) As String
nom = ""
On Error Resume Next
If cel.Name.Name Then nom = cel.Name.Name
End Function
Un module :
Option Explicit
Dim CollectionDeBouton() As CBtnClasse
Sub choisir(ok As Boolean)
Dim ctrls As Control
Dim i%
i = 1
For Each ctrls In choix.Controls
ReDim Preserve CollectionDeBouton(1 To i)
Set CollectionDeBouton(i) = New CBtnClasse
Set CollectionDeBouton(i).bouton = choix.Controls(ctrls.Name)
i = i + 1
Next
choix.Show
End Sub
Un module de classe :
Option Explicit
Public WithEvents bouton As MSForms.CommandButton
Private Sub bouton_Click()
' Debug.Print bouton.Name & " |" & Replace(Left(bouton.Caption, InStr(bouton.Caption, " : ")), " ", "") & "| " & bouton.Caption & " | " & "couleur : " & bouton.BackColor
Selection.Value = Replace(Left(bouton.Caption, InStr(bouton.Caption, " : ")), " ", "")
Selection.Interior.Color = bouton.BackColor
Selection.Font.Color = bouton.BackColor 'bouton.ForeColor
choix.Hide
End Sub
C'était pas gagné d'avance ... mais je me suis un peu décarcassé compte tenu de l'enjeu en temps passé pour les établir ! J'aurais pété un câble rien que d'en faire un à la main !