Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

susaita

XLDnaute Occasionnel
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
 

Pièces jointes

  • Planning de Présence.xlsm
    40.5 KB · Affichages: 74

susaita

XLDnaute Occasionnel
Bonjour Job,
bonjour le forum
merci beaucoup pour le code c'est exactement ce que je voulais..mais j'ai deux petites remarques que je voudrais citer :

***la liste déroulante je voulais l'interdire juste pour le dimanche donc j'ai changé ces deux lignes pour que la liste apparaît sur les samedi :
VB:
If Weekday(ActiveCell(9 - ActiveCell.Row), 2) > 6 Then Else _
  If c Is Nothing Or Weekday(Target(9 - Target.Row), 2) > 6 Then
mais le problème c'est que les samedis restent avec la même couleur orange ils prennent pas la couleur du code

*****en choisissant un code de la liste déroulante il prend du temps en montrant le nom du code avant qu'il se transforme en couleur : j'aimerais éviter ce petit beug comme ça une fois je clique sur un code dans la liste déroulante j'ai directement la couleur

Merci
 

job75

XLDnaute Barbatruc
Re,

Dans ce fichier (4), sur les colonnes AH:AT :

- formules plus simples en AH10 et suivantes

- format personnalisé 0;; pour masquer les valeurs zéro

- MFC séparée pour les bordures.

A+
 

Pièces jointes

  • Planning de Présence(4).xlsm
    45.2 KB · Affichages: 50

job75

XLDnaute Barbatruc
Re,

Allez un petit complément pour la colonne A :
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range
If Not IsDate("1-" & Sh.Name) Then Exit Sub
'---colonne A---
Set r = Intersect(Target, Sh.Range("A10:A" & Sh.Rows.Count), Sh.UsedRange)
If Not r Is Nothing Then
  Application.ScreenUpdating = False
  For Each r In r 'si entrées/effacements multiples
    r(1, 34).Resize(, [Codes].Count) = IIf(IsEmpty(r), "", "=COUNTIF(RC2:RC32,R9C)")
    If IsEmpty(r) Then r(1, 2).Resize(, 31) = ""
  Next
End If
'---colonnes B:AF---
Set Target = Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange)
If Target Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
For Each Target In Target 'si entrées/effacements multiples
  Set r = [Codes].Find(Target, , xlValues, xlWhole)
  If r Is Nothing Or Weekday(Target(9 - Target.Row)) = 1 Then
    If Target <> "" Then Target = ""
    Target.Interior.ColorIndex = xlNone 'RAZ
    Target.Font.ColorIndex = 2 'RAZ (police blanche sur B10:AF1048576)
  Else
    Target.Interior.Color = r.Interior.Color
    Target.Font.Color = r.Font.Color
  End If
Next
End Sub
Quand on ajoute/efface une formule en colonne A les formules en AH:AT s'ajoutent/s'effacent.

Et quand on l'efface son planning à droite s'efface aussi.

Edit : j'ai modifié les formules des MFC.

Fichier (5).

A+
 

Pièces jointes

  • Planning de Présence(5).xlsm
    45.1 KB · Affichages: 54
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour susaita,

Ah oui je n'avais pas vu que les noms en colonne A sont entrés par formule.

Je viens de modifier le post #20 et le fichier (5), maintenant tirez les formules vers le bas.

Edit : mais vos formules en colonna A ont un grave inconvénient.

Si l'on ajoute des noms dans la feuille "DATA" les noms en colonne A peuvent changer de ligne puisque vos formules les trient.

Alors les plannings ne correspondent plus !!!

Il faudrait dans ce cas revoir votre projet, mais là c'est une tout autre histoire...

A+
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour susaita, le forum,

Voyez ce fichier (6), il n'y a plus de formules pour les noms en colonne A.

J'ai supprimé leur liste en feuille "DATA", elle ne servait plus à rien.

Ajoutez ou effacez les noms que vous voulez dans la feuille concernée (normalement la dernière).

J'ai ajouté un tri sur les noms dans la macro :
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range
If Not IsDate(Sh.Name) Then Exit Sub
'---colonne A---
Set r = Intersect(Target, Sh.Range("A10:A" & Sh.Rows.Count), Sh.UsedRange)
If Not r Is Nothing Then
  Application.ScreenUpdating = False
  For Each r In r 'si entrées/effacements multiples
    r(1, 34).Resize(, [Codes].Count) = IIf(IsEmpty(r), "", "=COUNTIF(RC2:RC32,R9C)")
    If IsEmpty(r) Then r(1, 2).Resize(, 31) = ""
  Next
  Sh.Range("A10:AT" & Sh.Rows.Count).Sort Sh.[A10], Header:=xlNo 'tri sur les noms
End If
'---colonnes B:AF---
Set Target = Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange)
If Not Target Is Nothing Then
  Application.ScreenUpdating = False
  On Error Resume Next
  For Each Target In Target 'si entrées/effacements multiples
    Set r = [Codes].Find(Target, , xlValues, xlWhole)
    If r Is Nothing Or Weekday(Target(9 - Target.Row)) = 1 Then
      If Target <> "" Then Target = ""
      Target.Interior.ColorIndex = xlNone 'RAZ
      Target.Font.ColorIndex = 2 'RAZ (police blanche sur B10:AF1048576)
    Else
      Target.Interior.Color = r.Interior.Color
      Target.Font.Color = r.Font.Color
    End If
  Next
End If
End Sub
Bonne journée.
 

Pièces jointes

  • Planning de Présence(6).xlsm
    52 KB · Affichages: 36

job75

XLDnaute Barbatruc
Re,

Le délai d'affichage de la couleur ne vient pas de la macro, il suffit d'ajouter un Timer pour s'en rendre compte :
Code:
If Not Target Is Nothing Then
  Dim t
  t = Timer
  Application.ScreenUpdating = False
  On Error Resume Next
  For Each Target In Target 'si entrées/effacements multiples
    Set r = [Codes].Find(Target, , xlValues, xlWhole)
    If r Is Nothing Or Weekday(Target(9 - Target.Row)) = 1 Then
      If Target <> "" Then Target = ""
      Target.Interior.ColorIndex = xlNone 'RAZ
      Target.Font.ColorIndex = 2 'RAZ (police blanche sur B10:AF1048576)
    Else
      Target.Interior.Color = r.Interior.Color
      Target.Font.Color = r.Font.Color
    End If
  Next
  MsgBox Timer - t
End If
Cela ne vient pas non plus des MFC, il suffit de les supprimer, l'affichage reste lent.

Je ne sait pas d'où ça vient, il est possible que votre fichier soit vérolé.

A+
 

job75

XLDnaute Barbatruc
Re,

Bon rassurez-vous, votre fichier n'est pas vérolé.

J'ai testé sur un nouveau document vierge, sans aucun format, avec juste une feuille contenant la plage "Codes" et une feuille "Septembre-2016" avec les dates en ligne 8.

Il y a là encore un délai pour l'affichage de la couleur, c'est donc le fonctionnement normal sur Excel 2013.

Par curiosité j'ai neutralisé la ligne :
Code:
  'ActiveCell.Validation.Add xlValidateList, Formula1:="=Codes" 'liste de validation
Sans la liste de validation l'affichage est nettement plus rapide.

A+
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…