Remplissage Calendrier en fonction de couleurs

[Leskwal]

Bonjour le forum

Ça me fait plaisir de revenir vers vous !!!

Voilà mon p'tit problème.

J'ai joint un fichier pour l'exemple.

1/ Sur le tableau principal, j'insère les heures du matin et de l'après midi pour chaque journée.

2/ les heures du matin et de l'après midi s'additionnent et le résultat va se positionner sur le tableau de synthèse.
Total heures du LUNDI sur tous les LUNDI du TABLEAU RECAP
Total heures du MARDI ...etc

3/ Cependant si le LUNDI, MARDI, MERCREDI... à un fond coloré alors AUCUN RÉSULTAT ne s'inscrit.

Est-il possible d'avoir la solution en VBA, je n'y arrive vraiment pas ?...Arghhhh


Un grand MERCI d'avance

Cordialement

Pascal

 

[job75]

Re : Remplissage Calendrier en fonction de couleurs

Re,

Avec un tableau VBA (matrice) les données sont restituées d'un seul coup, c'est plus rapide :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, c As Range, t, mois As Byte, i As Byte, dat&, coul&, s#
Set P = [D4:F10]
Set c = [D14]
If Intersect(Target, Union(P, c.Resize(32, 3))) Is Nothing Then Exit Sub
t = c.Resize(32, 3) 'matrice, plus rapide
If Not IsDate(t(1, 1)) Then t(1, 1) = Date 'sécurité
mois = Month(t(1, 1))
t(1, 1) = DateSerial(Year(t(1, 1)), mois, 1) '1er du mois
For i = 2 To 32
  dat = t(1, 1) + i - 2
  If Month(dat) = mois Then
    t(i, 1) = i - 1
    t(i, 2) = UCase(Format(dat, "dddd"))
    coul = c(i, 2).Interior.Color
    s = Application.SumIf(P.Columns(1), t(i, 2), P.Columns(2))
    s = s + Application.SumIf(P.Columns(1), t(i, 2), P.Columns(3))
    t(i, 3) = IIf(coul = 16777215 And s > 0, s, "")
  Else
    t(i, 1) = "": t(i, 2) = "": t(i, 3) = "" 'jours 29 30 31
  End If
Next
'---restitution---
Application.EnableEvents = False 'désactive les événements
c.Resize(32, 3) = t
Application.EnableEvents = True 'réactive les événements
End Sub

Fichier (2).

Edit : durées d'exécution sur Win 7 - Excel 2010 :

- fichier (1) => 0,103 seconde

- fichier (2) => 0,005 seconde, donc 20 fois plus rapide.

A+

 

[Leskwal]

Re : Remplissage Calendrier en fonction de couleurs

Bonjour le forum, Job75

Je reviens d'un WE un peu chargé , et là, je découvre qu'une personne a fait un "Job" de dingue.

GENIAL, avant même d"essayer la soluce, je tiens vraiment à te remercier JOB.

Et, c'est parti pour la nuit ...

Encore un GRAND merci

Très cordialement

Pascal

 

[Leskwal]

Re : Remplissage Calendrier en fonction de couleurs

Bonjour tout le monde

Je reviens vers vous, car j'ai essayé d'adapter la soluce de Job75 à mon fichier réel, bah ça marche pas franchement top...

Le rafraichissement automatique quand il y'a une modification sur la feuille ne se fait pas, mais surtout, cela fonctionne pour le mois de Septembre, mais pas pour le mois d'Octobre (Voir fichier joint). Je n'ai fait que ces 2 mois...

Comme écrit plus haut, j'ai passé une partie de la nuit ... en vain !!!

Donc : AU SECOURS

Un grand MERCI d'avance pour votre aide future..

Pascal

 

[job75]

Re : Remplissage Calendrier en fonction de couleurs

Bonjour Leskwal, le forum,

Vu la rapidité de la dernière macro, il n'y a aucun inconvénient à l'exécuter chaque fois qu'on sélectionne ou modifie une cellule quelconque :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MAJ
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
MAJ
End Sub

Sub MAJ()
Dim P As Range, c As Range, t, mois As Byte, i As Byte, dat&, coul&, s#
Set P = [D4:F10]
Set c = [D14]
t = c.Resize(32, 3) 'matrice, plus rapide
If Not IsDate(t(1, 1)) Then t(1, 1) = Date 'sécurité
mois = Month(t(1, 1))
t(1, 1) = DateSerial(Year(t(1, 1)), mois, 1) '1er du mois
For i = 2 To 32
  dat = t(1, 1) + i - 2
  If Month(dat) = mois Then
    t(i, 1) = i - 1
    t(i, 2) = UCase(Format(dat, "dddd"))
    coul = c(i, 2).Interior.Color
    s = Application.SumIf(P.Columns(1), t(i, 2), P.Columns(2))
    s = s + Application.SumIf(P.Columns(1), t(i, 2), P.Columns(3))
    t(i, 3) = IIf(coul = 16777215 And s > 0, s, "")
  Else
    t(i, 1) = "": t(i, 2) = "": t(i, 3) = "" 'jours 29 30 31
  End If
Next
'---restitution---
Application.EnableEvents = False 'désactive les événements
c.Resize(32, 3) = t
Application.EnableEvents = True 'réactive les événements
End Sub

Fichier (3).

Edit : amusant, votre post #18 au même moment, je regarde.

A+

 

[job75]

Re : Remplissage Calendrier en fonction de couleurs

Re,

Votre post #18 : bien sûr c'est plus compliqué

Je ne sais pas quand je pourrai voir ça, je vais devoir voyager aujourd'hui.

A+

 

[job75]

Re : Remplissage Calendrier en fonction de couleurs

Re,

Il y a des cellules colorées dans tous les sens

Et le tableau hebdomadaire n'a plus rien à voir avec ce qu'il était précédemment.

Vous avez trop compliqué le problème, c'est devenu un projet lourd qui nécessite beaucoup de temps.

Ce n'est donc plus le sujet de ce fil, je pense que je n'irai pas plus loin, désolé.

A+

 

[Leskwal]

Re : Remplissage Calendrier en fonction de couleurs

Re

Ok job75.

Encore un grand merci pour le temps consacré.

Très cordialement

Pascal

 

[job75]

Re : Remplissage Calendrier en fonction de couleurs

Re,

De retour à Paris.

J'ai conclu trop vite sur votre fichier, a priori le projet n'est pas lourd.

En effet il n'y a au plus que 12 mois dans chaque feuille.

Avec ma dernière macro, la durée d'exécution devrait être 0,005 x 12 = 0,060 seconde, ce qui est très acceptable.

Il faudrait juste que vous précisiez une chose.

Pour les couleurs des cellules, faut-il considérer celles de la 1ère colonne, de la 2ème colonne ?

Suffit-il qu'une des deux soit colorée ?

A+

 

[job75]

Re : Remplissage Calendrier en fonction de couleurs

Bonjour à tous,

Je ne vais pas attendre la Saint-Glinglin, alors je suppose que pour chaque mois on affiche les heures en colonne 3 s'il n'y a pas de couleur en colonne 1 ni en colonne 2.

Les 3 macros dans ThisWorkbook :

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
MAJ Sh
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
MAJ Sh
End Sub

Sub MAJ(Sh As Object)
If Not Sh.Name Like "####*" Then Exit Sub
Dim an%, P As Range, n As Byte, c As Range, mois As Byte
Dim t, i As Byte, dat&, coul1&, coul2&, s#
an = Val(Left(Sh.Name, 4)) 'année
Set P = Sh.[A41:H47]
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les événements
For n = 1 To 12 'pour 12 mois
  Set c = Sh.[A1]
  Set c = c(, 3 * n - 2)
  c = DateSerial(an, 8 + n, 1) 'début le 01/09
  mois = Month(c)
  t = c.Resize(32, 3) 'matrice, plus rapide
  For i = 2 To 32
    dat = t(1, 1) + i - 2
    If Month(dat) = mois Then
      t(i, 1) = i - 1
      t(i, 2) = UCase(Format(dat, "dddd"))
      coul1 = c(i, 1).Interior.Color
      coul2 = c(i, 2).Interior.Color
      s = Application.SumIf(P.Columns(1), t(i, 2), P.Columns(8))
      t(i, 3) = IIf(coul1 = 16777215 And coul2 = 16777215 And s > 0, s, "")
    Else
      t(i, 1) = "": t(i, 2) = "": t(i, 3) = "" 'jours 29 30 31
    End If
  Next
  '---restitution du mois---
  c.Resize(32, 3) = t
Next
Application.EnableEvents = True 'réactive les événements
End Sub

Elle s'exécute en 0,045 seconde sur Win 7 - Excel 2010.

Fichier joint.

Nota : j'ai supprimé tous les noms définis, ils ne servaient à rien.

A+

 

[Leskwal]

Re : Remplissage Calendrier en fonction de couleurs

Bonjour le forum

Vraiment désolé job75 de ne pas avoir répondu. Un "peu" pris par le boulot....

Comme vous m'aviez annoncé que vous démissionnez du projet, j'ai essayé de me débrouiller en utilisant votre proposition de code.

Ce que que je pense avoir réussi en utilisant une boucle For Next (de 1 à 12 pour les mois avec une variable).

J'avais l'intention de diffuser mon fichier une fois abouti, sachant qu'il comprend déjà la mention

    Application.StatusBar = " Application Automatique réalisée par PL / ANNEE 2014 avec un gros remerciement à Job75 d'Excel Download pour son aide précieuse"

Voilà. Du coup je vais voir votre nouvelle proposition.

Un très grand merci pour votre investissement et désolé pour ma non réactivité.

Très cordialement

Pascal

 

[Leskwal]

Re : Remplissage Calendrier en fonction de couleurs

Job75

Je reviens vers vous pour vous remercier.

Waouhhh, à mon niveau c'est du lourd.
J'essaie encore aujourd'hui de comprendre chacune des parties du code...

Beaucoup de choses m"échappent, mais j"y arriverai ...

A très bientôt et merci encore

Pascal

 

[Leskwal]

Re : Remplissage Calendrier en fonction de couleurs

Bonjour le Forum, Job75

Comme vu sur l'autre discussion, le fichier pas encore terminé mais bien avancé

Explications :

Le chef de service complète le calendrier à partir de l'onglet "Semaine A OU A+B".

A faire

1/ Lier (les couleurs) des numéros de jour des onglets "Semaine B" et "SYNTHESE" à l'onglet "Semaine A OU A+B".
Pour exemple quand le chef de service détermine les jours de fermeture de l'entreprise, par couleur, alors cette même couleur va se positionner aux mêmes endroits sur les deux autre onglets.

2/ Lorsque le chef de service détermine, avec la couleur gris clair dans "Semaine A OU A+B" (DANS LA COLONNE JOURS DE SEMAINE), la semaine B, alors dans l'onglet "Semaine B", ce qui était en gris clair dans "Semaine A OU A+B" devient vierge en "Semaine B" et et ce qui était de couleur "nul" dans "Semaine A OU A+B" devient d'une autre couleur (Bleu par exemple) dans "Semaine B".
Pour faire simple :
"Semaine B" est le négatif de "Semaine A OU A+B" concernant la couleur de semaine B

D'autres modifs ont été apportées.
Quand un salarié modifie exceptionnellement la valeur d'une journée, cette valeur est fixée par l'ajout d'une couleur indiquant que la cellule à été modifiée. Car auparavant on pouvait modifier le volume d'une journée. Mais dès qu'on effectuait une action relançant le code => remise de la valeur par défaut dans la cellule.
J'ai donc créé une condition couleur indiquant que si la cellule avait une couleur (et donc avait été modifiée) => pas de traitement.

Voilà, espérant que ce fichier pourra rendre service à d'autres.

Je suis cependant en recherche de soluces concernant les 2 choses restant à faire.

Un grand merci à tous d'avance

Cordialement

Pascal