XL 2013 Colorer les jours dans un planning de présence (Résolu par JOB75)

[susaita]

Bonjour a tous,
dans le fichier ci-joint j'ai un planning de présence et ce que je souhaite avoir c'est un code vba pour colorer chaque cellule par les couleurs qui se trouvent sur l'onglet DATA, cad quand je choisi un motif d'absence dans la liste que j'ai sur l'onglet septembre-2016 il me donne la couleur qui lui correspond toute en sachant que le code sera valable pour les mois qui vont s'ajouter par la suite.

puis je veux interdire la visualisation de la liste déroulante dans les dimanches

Merci d'avance

 

[susaita]

re,
j'ai neutralisé aussi la même liste mais la liste de validation a disparu

 

[job75]

Re,

re,
j'ai neutralisé aussi la même liste mais la liste de validation a disparu

Ben c'est normal, quand on supprime un code il ne s'exécute plus...

Pour tester tapez l'un des codes dans la cellule...

Par ailleurs comme votre macro NewMonth_Sheet était du genre usine à gaz je l'ai revue :

Sub NewMonth_Sheet()
Dim w As Worksheet, dat As Date
For Each w In Worksheets
  If IsDate(w.Name) Then If CDate(w.Name) > dat Then dat = CDate(w.Name)
Next
If dat Then
  Application.ScreenUpdating = False
  Application.Goto ActiveSheet.[A1], True 'cadrage
  Sheets(Format(dat, "mmmm-yyyy")).Copy After:=Sheets(Sheets.Count)
  With Sheets(Sheets.Count)
    .Name = Application.Proper(Format(DateAdd("m", 1, dat), "mmmm-yyyy"))
    Application.EnableEvents = False
    With .Range("B10:AF" & .Rows.Count)
      .Value = Empty
      .Interior.ColorIndex = xlNone
      .Font.ColorIndex = 2 'police blanche
    End With
    Application.EnableEvents = True
    .Columns("AD:AF").Hidden = True '29 30 31
    .[AC8:AF8].SpecialCells(xlCellTypeFormulas, 1).Columns.Hidden = False
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1], True 'cadrage
  End With
End If
End Sub

Notez le masquage des 29 30 ou 31 du mois.

Fichier (7).

Edit 1 : j'ai aussi ajouté une Workbook_Open pour éviter l'invite à la fermeture.

Edit 2 : j'ai corrigé les fichiers (5) et (6), les formules NB.SI s'étaient décalées suite à une fausse manoeuvre.

A+

 

[susaita]

Bonjour Job,
Merci beaucoup pour l’importance et le temps que vous avez consacré à ma problématique...

Cordialement
Susaita

 

[susaita]

Bonjour Job,
après la modification que vous avez faite sur mon module NewMonth vous avez oublié de rajouter à voytre nouveau code l'ajout d'une ligne dans l'onglet Recap après l'ajout d'un nouveau mois

je rajoute cette partie du code que j'avais dans mon ancien module ?? et dans quel endroit exactement??

Sheets("Recap").Activate
Range("D" & Cells(Rows.Count, 4).End(xlUp).Row - 1).EntireRow.Copy
Range("A" & Cells(Rows.Count, 4).End(xlUp).Row).EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = False

 

[job75]

Bonjour susaita, le forum,

Je me disais aussi...

Votre feuille "RECAP" ne tenait pas la route, je l'ai revue dans ce fichier (8) avec ce code :

Private Sub Worksheet_Activate()
Dim deb As Range, critere As Range, a(), w As Worksheet, n%, i As Variant
Set deb = [D9] 'adapter éventuellement
Set critere = [E7] 'adapter éventuellement
ReDim a(1 To Worksheets.Count, 1 To 3)
For Each w In Worksheets
  If IsDate(w.Name) Then
    n = n + 1
    a(n, 1) = CDate(w.Name)
    a(n, 2) = w.Name
    a(n, 3) = Application.Sum(w.[AH8].CurrentRegion)
  End If
Next
Application.ScreenUpdating = False
critere.Validation.Delete 'RAZ
Rows(deb.Row + 1 & ":" & Rows.Count).Delete 'RAZ
If n = 0 Then Exit Sub
With deb(2, 0).Resize(n, 3) 'colonne auxiliaire C pour les dates
  .Value = a
  .Sort .Columns(1), Header:=xlNo 'tri
  .Columns(1) = Empty
  critere.Validation.Add xlValidateList, Formula1:="=" & .Columns(2).Address 'liste de validation
  i = Application.Match(critere, .Columns(2), 0)
  If IsError(i) Then
    .Rows(1).Resize(n).Hidden = True
  Else
    .Cells(i, 4).Resize(n - i + 1) = "=N(R[-1]C)+RC[-1]"
    .Cells(n + 1, 2) = "TOTAL"
    .Cells(n + 1, 3) = "=SUM(R[" & i - n - 1 & "]C:R[-1]C)"
    .Cells(n + 1, 4) = "=R[-1]C"
    .RowHeight = 22
    .Rows(n + 1).RowHeight = 27
    If i > 1 Then .Rows(1).Resize(i - 1).Hidden = True
  End If
End With
With Me.UsedRange: End With 'actualise la barre de défilement verticale
ActiveWindow.ScrollRow = 1
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [E7]) Is Nothing Then Worksheet_Activate
End Sub

Dans cette feuille aussi les bordures sont appliquées par MFC.

Et votre "Sheetlist" dans la feuille "DATA" était plus nuisible qu'autre chose, je l'ai supprimée.

A+

 

[job75]

Bonjour susaita, le forum,

J'ai créé un fichier de 120 feuilles et découvert un phénomène curieux pour la suppression des lignes.

L'activation de la feuille "RECAP Test1" prend chez moi environ 4 secondes, c'est beaucoup trop.

Cela est dû pour l'essentiel à la ligne de code :

Rows(deb.Row + 1 & ":" & Rows.Count).Delete 'RAZ, à tester

Cela ne change pas grand-chose avec le code :

'deb.CurrentRegion.Offset(1).EntireRow.Delete 'ne change pas grand-chose

Il est facile de vérifier que cela ne vient pas de la MFC (il suffit de la supprimer).

Pourtant la suppression d'un tableau de 120 lignes ce n'est pas la mer à boire !!!

Si maintenant on active la feuille "RECAP Test2" avec le code :

Rows.Hidden = False 'RAZ nouveau
Rows(deb.Row + 1 & ":" & Rows.Count).RowHeight = 22 'RAZ nouveau
Rows(deb.Row + 1 & ":" & Rows.Count) = Empty 'RAZ nouveau

cela ne prend que 0,28 seconde.

Alors sans plus chercher à comprendre utilisez ce fichier (9)...

Bonne journée.

 

[susaita]

Bonjour Job,
merci beaucoup pour toutes les modifications que vous avez fait,
la feuille RECAP j'aimerais qu'elle soit comme dans le fichier ci-joint :
en D12 : je souhaite avoir une liste déroulante avec les noms variable et j'ai créé une autre sur E9 avec les mois.
puis de E12 à Q12 je dois avoir le nombre d'absence par mois
pour finir les dates dans R4 et V4 de chaque mois je veux qu'elles soit séparées comme dans ce fichier et ne pas les grouper en une seule cellule

Bonne journée

 

[job75]

Re,

Il était temps de vous réveiller, mais une 2ème liste déroulante pour les noms serait tout à fait inutile !

Le nouveau code de la feuille "RECAP" :

Private Sub Worksheet_Activate()
Dim deb As Range, critere As Range, a(), w As Worksheet, n%, i As Variant
Set deb = [D12] 'adapter éventuellement
Set critere = [E9] 'adapter éventuellement
'---MAJ de la liste des mois---
ReDim a(1 To Worksheets.Count, 1 To 2)
For Each w In Worksheets
  If IsDate(w.Name) Then
    n = n + 1
    a(n, 1) = CDate(w.Name)
    a(n, 2) = w.Name
  End If
Next
Application.ScreenUpdating = False
critere.Validation.Delete 'RAZ
With Sheets("DATA")
  .Range("A2:B" & .Rows.Count) = Empty
  .[A2].Resize(n, 2) = a
  .[A2].Resize(n, 2).Sort .[A2], Header:=xlNo 'tri sur les dates
  .[B2].Resize(IIf(n, n, 1)).Name = "Sheetlist" 'plage nommée
  i = Application.Match(critere, [Sheetlist], 0)
End With
If n Then critere.Validation.Add xlValidateList, Formula1:="=Sheetlist"
'---remplissage de la feuille RECAP---
Rows(deb.Row & ":" & Rows.Count).RowHeight = 22 'hauteur modifiable
Rows(deb.Row & ":" & Rows.Count) = Empty 'RAZ
If n = 0 Or IsError(i) Then Exit Sub
With Sheets(CStr(critere)).[A9].CurrentRegion.Offset(2)
  n = .Rows.Count - 2
  If n < 1 Then Exit Sub
  deb.Resize(n) = .Columns(1).Value
  deb(1, 2).Resize(n, [Codes].Count) = .Cells(1, 34).Resize(n, [Codes].Count).Value
  deb(n + 1) = "TOTAL"
  deb(n + 1, 2).Resize(, [Codes].Count) = "=SUM(R[-" & n & "]C:R[-1]C)"
End With
With Me.UsedRange: End With 'actualise la barre de défilement verticale
ActiveWindow.ScrollRow = 1
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [E9]) Is Nothing Then Worksheet_Activate
End Sub

Fichier joint.

Edit : j'avais oublié d'enlever un + 1 dans la RAZ...

pour finir les dates dans R4 et V4 de chaque mois je veux qu'elles soit séparées comme dans ce fichier et ne pas les grouper en une seule cellule

Moi je veux pas car c'est stupide

A+

 

[susaita]

Merci infiniment Job, j'ai proposé une autre liste déroulante pour les noms parce que je ne pensais pas qu'un résultat pareil est possible
à vrai dire ce fichier est beaucoup mieux que celui je pensais pouvoir avoir

je vous souhaite une très belle journée
à très bientôt

 

[job75]

Re,

Avec 120 feuilles et la dernière solution je découvre une autre curiosité.

L'activation de la feuille "RECAP" prend maintenant entre 2 et 3 secondes.

Pour l'essentiel c'est dû au fait qu'on nomme la plage "Sheetlist" :

  .[B2].Resize(IIf(n, n, 1)).Name = "Sheetlist" 'plage nommée

Bizarre, vous avez dit bizarre ??? Et là on ne peut rien améliorer...

A+

 

[mapomme]

Re,
J'ai l'impression que c'est dû au nombre de feuilles du classeur bien que je ne vois pas le rapport. J'ai fait une petite macro pour tester la durée d'activation du classeur RECAP Test (120 feuilles).xlsm en diminuant chaque fois le nombre de feuille 'Mois' qui semble confirmer cela.

• ouvrir un fichier de type Ce lien n'existe plus (ou télécharger celui de job75)
• ouvir le fichier joint
• cliquer sur le bouton 'GO'

Les valeurs affichées sont celles de mon vieux dinosaure d'ordi (conscruit en 2007, processeur Intel Core 2 Duo E6420, 2 Go de mémoire et win 10)

 

[JCGL]

Bonjour à tous,

• ouvrir un fichier de type RECAP Test (120 feuilles).xlsm (ou télécharger celui de pierrejean)

Pierre-Jean ou Job75 ?

A+ à tous

 

[mapomme]

Bonjour JCGL ,

(...) Pierre-Jean ou Job75 ? (...)

Bien vu! (il y a quelques jours, j'ai exactement écrit l'opposé )

Je vais chez le coiffeur. Une fois ma crinière ratiboisée, mon cerveau sera peut-être un peu plus ventilé par ces temps de canicule.

A+

 

[JCGL]

Bonjour à tous,

Méfiance... Tu risques de perdre toute ta force comme Samson...

A+ à tous

 

[job75]

Re, hello les amis,

J'ai l'impression que c'est dû au nombre de feuilles du classeur

Oui ça c'est sûr, mais justement 120 feuilles ou un tableau de 120 lignes c'est très peu de chose pour un classeur Excel (qui ne pèse alors que 700 Ko et des poussières).

Et as-tu vu mon post #40 concernant la plage nommée "Sheetlist" ???

A+