Accueil

 

Soustraction de dates Ajout de jours à une date Aujourdhui() Maintenant() Date() DateVal() JourSem() DateDif() Fonctions Macro Complémentaires NB.JOURS.OUVRES() SERIE.JOUR.OUVRE() FIN.MOIS() MOIS.DECALER() NO.SEMAINE() Exemples Jours fériés Planning Jours ouvrés Samedi Calendriers Planning

-Planning : coloriage en fonction du caractère frappé -Planning avec barre d'outils -Planning avec liste déroulante -Planning mensuel -Planning mensuel vertical -Planning images -Planning Images2 -Planning wingdings -Planning wingdings2 -Conversion planning -BD sous forme de planning -Création d'une BD à partir d'un planning -Planning salles -Planning véhicules -Planning double affectation(Stage+Date) -Choix d'une photo dns un ListBox photo -Calendrier stages -Planning tâches -Planning semaines -Saisie d'une date dans une cellule -Saisie date et heure -Saisie de 2 dates -Formulaire avec calendrier inclus

Soustraction de dates

Lorsqu'une date est saisie sous la forme jj/mm/aa, le format Date lui est automatiquement appliqué.
En réalité, la cellule contient le nombre de jours par rapport au 1er janvier 1900 (39096 pour 14/01/2007).
Le nombre de jours entre deux dates sous la forme JJ/MM/AA s'obtient en soustrayant les deux dates.

Addition de jours à une date

En ajoutant un nombre à une date sous la forme JJ/MM/AA et en appliquant le format Date,
on obtient la date correspondante.

Si on entre dans une cellule une date suivie d'une heure (01/01/90 12:00 par exemple),
EXCEL place dans la cellule le nombre 32874,5 et lui applique le format JJ/MM/AA HH:MM.
On peut donc soustraire 2 cellules contenant des dates et des heures.
On obtient le nombre de jours entre les 2 dates.

AUJOURDHUI()
MAINTENANT()

Donne le nombre de jours de la date actuelle par rapport au 1/1/1900.
En appliquant un format du type date à la cellule contenant cette fonction,
on fait apparaître la date actuelle. La fonction MAINTENANT() retourne également une partie décimale
qui représente l'heure actuelle.

DATE(année;mois;jour)

Donne le nombre de jours de la date spécifiée par rapport au 1/1/1900.

=DATE(2007;01;14) Donne 14/1/2007

Mise en forme conditionnelle des week-end:

• Sélectionner B6:AF15
• Format/Mise en forme conditionnelle/La formule est
• =JOURSEM(B$6;2)>5

Autres exemples:

15 du mois suivant:
DATE(ANNEE(A1);MOIS(A1);15) donne le 15 du mois suivant

n an plus tard (B1 contient le nombre de d'années)
=DATE(ANNEE(A1)+B1;MOIS(A1);JOUR(A1))

Avec gestion du 29/2
=DATE(ANNEE(A1)+B1;MOIS(A1);JOUR(A1))-(MOIS(DATE(ANNEE(A1)+B1;MOIS(A1);JOUR(A1)))<>MOIS(A1))

3ansPlusTard

n mois plus tard (B1 contient le nombre de mois)

=DATE(ANNEE(A1);MOIS(A1)+B1;JOUR(A1))

Avec gestion du 29/2
=SI(MOIS(DATE(ANNEE(A1);MOIS(A1)+B1;JOUR(A1)))<>MOD(MOIS(A1)+B1;12);DATE(ANNEE(A1);
MOIS(A1)+B1+1;1)-1;DATE(ANNEE(A1);MOIS(A1)+B1;JOUR(A1)))

DATEVAL(date_chaîne)

Transforme en date une chaîne contenant une date.

=DATEVAL("01/01/2007") Donne 39083

JOURSEM(date;retour)

Donne le jour de la semaine (1,2,3,..7) d'une date

• Si retour=1 : 1=Dimanche, 2:Lundi,...
• Si retour=2: 1=Lundi, 2=Mardi..

JOUR(date)

Donne le jour du mois (1,2,3,..31).

=JOUR(MAINTENANT())

MOIS(date)

Donne le mois (1,2,..12)

=MOIS(MAINTENANT())

DATEDIF(Date1;Date2;paramètre)

La fonction Datedif(Date1;Date2;paramètre) permet d'obtenir la différence entre 2 dates.
Un paramètre permet de spécifier si la différence doit être exprimée en Années (y), en Mois (m)
ou en Jours(d).
Sur l'exemple, on obtient l'âge.

Fonctions de la macro complémentaire Utilitaire Analyse

Pour accéder à ces fonctions, il faut cocher Outils/Macro Complémentaires/Utilitaire d'Analyse

NB.JOURS.OUVRES(début;fin;jours_fériés)

Donne le nb de jours ouvrés entre 2 dates

=SERIE.JOUR.OUVRE(début;nb_jours_ouvrés;jours_fériés)

Ajoute un nb de jours ouvrés à une date.
Cocher Outils/Macro Complémentaires/Utilitaire d'Analyse

=FIN.MOIS(date;nb_mois)

Donne la fin du mois.

=FIN.MOIS(A1;0)

Sans macro complémentaire

=DATE(ANNEE(A1);MOIS(A1)+1;0)

=MOIS.DECALER(date;nb_mois)

Décale une date d'un nombre de mois.

=MOIS.DECALER(A1;6))

=NO.SEMAINE(date;1 ou 2)

1: la semaine commence le dimanche
2: la semaine commence le lundi

Exemples

Pâques

=ARRONDI(DATE(Année;4;MOD(234-11*MOD(Année;19);30))/7;0)*7-6

Nombre de jours d'un mois

A1 contient 1,2,3,...

=JOUR(DATE(2009;A1+1;1)-1)
=JOUR(DATE(2009;A1+1;0))

A1 contient Janvier,Février,Mars,..

=JOUR(DATE(2009;MOIS("1/"&A1&"/2009")+1;0))

A1 contient une date

=JOUR(DATE(ANNEE(A1);MOIS(A1)+1;1)-1)

No de semaine

=ENT(MOD(ENT((A1-2)/7)+0,6;52+5/28))+1

Dernier jour du mois en cours

=DATE(ANNEE(AUJOURDHUI());MOIS(AUJOURDHUI())+1;0)

Nombre de dimanches entre 2 dates

=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(B4&":"&C4)))=1)*1)

Lundi de la semaine en cours

=AUJOURDHUI()-JOURSEM(AUJOURDHUI()-1)+1

Samedi,Dimanche,Lundi,.... suivant

La date est en A1

Début & fin d'une semaine

Semaine

=NOMPROPRE("Du "&TEXTE(7*B2+DATE($A$2;1;3)-JOURSEM(DATE($A$2;1;3))-5;"jjjj jj mmmm aaaaa"))&" au "&
NOMPROPRE(TEXTE(7*B2+DATE($A$2;1;3)-JOURSEM(DATE($A$2;1;3));"jjjj jj mmmm aaaaa"))

Lundi semaine dernière

=AUJOURDHUI()-JOURSEM(AUJOURDHUI())-5  

Nombre de jours ouvrés entre 2 dates - samedi jour ouvré -

=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(A2&":"&B2));2)<7)*(NB.SI(fériés;LIGNE(INDIRECT(A2&":"&B2)))=0))
ou
=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(A2&":"&B2));2)<7)*ESTNA(EQUIV(LIGNE(INDIRECT(A2&":"&B2));fériés;0)))

JoursOuvrés2Dates

Nombre de jours entre 2 dates différents de mercredi et dimanche

Les dates sont en A1 et B1

=SOMMEPROD(--ESTNA(EQUIV(JOURSEM(LIGNE(INDIRECT(A1&":"&B1)));{1;4};0)))

Nombre de jours ouvrés entre 2 dates en A2,B2 (sans samedi,dimanche, jours fériés, vacances)

=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(A2&":"&B2));2)<6)*(NB.SI(fériés;LIGNE(INDIRECT(A2&":"&B2)))=0)*(ESTNA(EQUIV(LIGNE(INDIRECT(A2&":"&B2));LIGNE(INDIRECT(dvac1&":"&fvac1));0)))*(ESTNA(EQUIV(LIGNE(INDIRECT(A2&":"&B2));LIGNE(INDIRECT(dvac2&":"&fvac2));0))))

Samedis non férié entre 2 dates en B1 et b2

=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(B1&":"&B2));2)=6)*(NB.SI(fériés;LIGNE(INDIRECT(B1&":"&B2)))=0))

Dimanches non fériés entre 2 dates en B1 et b2

=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(B1&":"&B2));2)=7)*(NB.SI(fériés;LIGNE(INDIRECT(B1&":"&B2)))=0))

Nb de jours fériés entre 2 dates en B1 et B2

=SOMMEPROD(NB.SI(fériés;LIGNE(INDIRECT(B1&":"&B2))))

Samedi+Dimanche+Nb de jours fériés entre 2 dates en A2 et B2

=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(A2&":"&B2));2)>5)*(NB.SI(fériés;LIGNE(INDIRECT(A2&":"&B2)))=0))+SOMMEPROD(NB.SI(fériés;LIGNE(INDIRECT(A2&":"&B2))))

Nombre de dimanches dans le mois

=SOMMEPROD(--(JOURSEM(LIGNE(INDIRECT(DATE(an;Mois;1)&":"&DATE(an;Mois+1;0)));2)>6))

Nombre de samedis et dimanches dans le mois

=SOMMEPROD(--(JOURSEM(LIGNE(INDIRECT(DATE(an;Mois;1)&":"&DATE(an;Mois+1;0)));2)>5))

Décalage x mois

Date en A1, nombre de mois en B1

=SI(MOIS(DATE(ANNEE(A1);MOIS(A1)+B1;JOUR(A1)))<>MOD(MOIS(A1)+B1;12);DATE(ANNEE(A1);MOIS(A1)+B1+1;1)-1;DATE(ANNEE(A1);MOIS(A1)+B1;JOUR(A1)))

Décalage 1 année

=DATE(ANNEE(A1)+1;MOIS(A1);JOUR(A1))-(MOIS(DATE(ANNEE(A1)+1;MOIS(A1);JOUR(A1)))<>MOIS(A1))

Liste des vendredis entre 2 dates

-Sélectionner n cellules
=SI(ESTNUM(PETITE.VALEUR(SI(JOURSEM(LIGNE(INDIRECT(A1&":"&A2)))=6;LIGNE(INDIRECT(A1&":"&A2)));
{1;2;3;4;5}));PETITE.VALEUR(SI(JOURSEM(LIGNE(INDIRECT(A1&":"&A2)))=6;
LIGNE(INDIRECT(A1&":"&A2)));{1;2;3;4;5});"")
Valider avec Maj+Ctrl+entrée

Liste des Samedis/Dimanches et jours fériés d'une année

En A3:
=SI(A2<>"";SI(MIN(SI((JOURSEM(A2+LIGNE($1:$7);2)>5)+(NB.SI(fériés;A2+LIGNE($1:$7))=1);A2+
LIGNE($1:$7)))<=DATE(an;12;31);
MIN(SI((JOURSEM(A2+LIGNE($1:$7);2)>5)+(NB.SI(fériés;A2+LIGNE($1:$7))=1);A2+LIGNE($1:$7)));"");"")
Valider avec Maj+Ctrl+entrée

SamediDimancheFériésAnnée
DimancheEtFériésAnnée

Liste des dimanches et jours fériés du mois choisi

-Sélectionner 9 cellules
=PETITE.VALEUR(SI((JOURSEM(LIGNE(INDIRECT(DATE(an;Mois;1)&":"&DATE(an;Mois+1;0))))=1)+
(NB.SI(fériés;LIGNE(INDIRECT(DATE(an;Mois;1)&":"&DATE(an;Mois+1;0))))>0);LIGNE(INDIRECT(DATE(an;Mois;1)&":"&
DATE(an;Mois+1;0))));LIGNE($1:$9))
Valider avec Maj+Ctrl+entrée

Liste des jours fériés de l'année qui sont des Samedi ou Dimanche

-Sélectionner 5 cellules
=PETITE.VALEUR(SI((NB.SI(fériés;LIGNE(INDIRECT(DATE(an;1;1)&":"&DATE(an;12;31))))>0)*(JOURSEM(LIGNE(INDIRECT(DATE(an;1;1)&":"&DATE(an;12;31)));2)>5);LIGNE(INDIRECT(DATE(an;1;1)&":"&DATE(an;12;31))));LIGNE($1:$5))
-Valider avec Maj+ctrl+entrée

Jours fériés

Pour obtenir les fêtes mobiles, nous calculons la date de pâques. Le lundi de pâques s'ontient en ajoutant 1.
Le Jeudi de l'Ascension s'obtient en ajoutant 39.
Le lundi de la pentecôte s'obtient en ajoutant 50.

- Jours fériés -

Nombre de jours ouvrés par mois

JoursOuvresMois

Jours ouvrés mois
=NB.JOURS.OUVRES(DATE(an;A2;1);DATE(an;A2+1;0);fériés)
=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(DATE(an;A2;1)&":"&DATE(an;A2+1;0)));2)<6)*(NB.SI(fériés;LIGNE(INDIRECT(DATE(an;A2;1)&":"&DATE(an;A2+1;0))))=0))

Sam+Dim+JF mois
=DATE(an;A2+1;0)-DATE(an;A2;0)-SOMMEPROD((JOURSEM(LIGNE(INDIRECT(DATE(an;A2;1)&":"&DATE(an;A2+1;0)));2)<6)*(NB.SI(fériés;LIGNE(INDIRECT(DATE(an;A2;1)&":"&DATE(an;A2+1;0))))=0))

Nb JF <>Sam/Dim
=SOMMEPROD((JOURSEM(LIGNE(INDIRECT(DATE(an;A2;1)&":"&DATE(an;A2+1;0)));2)<6)*(NB.SI(fériés;LIGNE(INDIRECT(DATE(an;A2;1)&":"&DATE(an;A2+1;0))))=1))

Jour ouvré précédent

La date est en A2

Avec la macro complémentaire Utilitaire analyse:=SERIE.JOUR.OUVRE(A2;-1;fériés)

ou

=MAX((JOURSEM(A2-LIGNE(1:6);2)<6)*(NB.SI(Fériés;A2-LIGNE(1:6))=0)*(A2-LIGNE(1:6)))
Valider avec Maj+Ctrl+entrée

Jours ouvré précédent sans le mercredi

=MAX((JOURSEM(A2-LIGNE(1:6);2)={1.2.4.5})*(NB.SI(Fériés;A2-LIGNE(1:6))=0)*(A2-LIGNE(1:6)))
Valider avec Maj+Ctrl+entrée

Prochain jour ouvré

La date est en A2

=SERIE.JOUR.OUVRE(A2;1;fériés)

ou

=MIN(SI((JOURSEM(A2+LIGNE(1:6);2)<6)*(NB.SI(fériés;A2+LIGNE(1:6))=0)<>0;(A2+LIGNE(1:6))))
Valider avec Maj+Ctrl+entrée

x jours ouvrés plus tard (samedi,dimanche fériés)

A2 contient la date et B2 le nombre de jours ouvrés à ajouter

=PETITE.VALEUR(SI((JOURSEM(A2+LIGNE(1:50);2)<6)*(NB.SI(fériés;A2+LIGNE(1:50))=0);A2+LIGNE(1:50));B2)
valider avec maj+ctrl+entrée

x jours ouvrés avant(samedi,dimanche fériés)

A2 contient la date et B2 le nombre de jours ouvrés à retrancher

=GRANDE.VALEUR(SI((JOURSEM(A2-LIGNE(1:50);2)<6)*(ESTNA((EQUIV(A2-LIGNE(1:50);fériés;0))));A2-LIGNE(1:50));B2)
valider avec maj+ctrl+entrée

x jours ouvrés plus tard (mercredis,samedis,dimanches fériés)

A2 contient la date et B2 le nombre de jours ouvrés à ajouter

=PETITE.VALEUR(SI((JOURSEM(A2+LIGNE(1:50);2)={1.2.4.5})*(NB.SI(fériés;A2+LIGNE(1:50))=0);A2+LIGNE(1:50));B2)
valider avec maj+ctrl+entrée

x jours ouvrés plus tard (dimanche férié)

A2 contient la date et B2 le nombre de jours ouvrés à ajouter

=PETITE.VALEUR(SI((JOURSEM(A2+LIGNE(1:50);2)<7)*(NB.SI(fériés;A2+LIGNE(1:50))=0);A2+LIGNE(1:50));B2)
valider avec maj+ctrl+entrée

Liste des Jours ouvrés d'une année

1er jour en D2:

=MIN(SI((JOURSEM(DATE(an;1;0)+LIGNE($1:$7);2)<6)*(NB.SI(fériés;DATE(an;1;0)+LIGNE($1:$7))=0);
DATE(an;1;0)+LIGNE($1:$7)))
Valider avecMaj+trl+entrée

2e jour en D3:

=SI(D2<>"";SI(MIN(SI((JOURSEM(D2+LIGNE($1:$7);2)<6)*(NB.SI(fériés;D2+LIGNE($1:$7))=0);
D2+LIGNE($1:$7)))<=DATE(an;12;31);
MIN(SI((JOURSEM(D2+LIGNE($1:$7);2)<6)*(NB.SI(fériés;D2+LIGNE($1:$7))=0);D2+LIGNE($1:$7)));"");"")

JOAnnée

JOsansVacances

Liste des Jours ouvrés sans le mercredi

1er jour en D2:

=MIN(SI((JOURSEM(DATE(An;1;0)+LIGNE($1:$7);2)<6)*(JOURSEM(DATE(An;1;0)+LIGNE($1:$7);2)<>3)*(NB.SI(fériés;DATE(An;1;0)+LIGNE($1:$7))=0);DATE(An;1;0)+LIGNE($1:$7)))
Valider avec Maj+ctrl+entrée

2e jour en D3:

=MIN(SI((JOURSEM(D2+LIGNE($1:$7);2)<6)*(JOURSEM(D2+LIGNE($1:$7);2)<>3)*(NB.SI(fériés;D2+LIGNE($1:$7))=0);D2+LIGNE($1:$7)))

Premier jour ouvré du mois

La date du premier jour du mois est en A1

=SERIE.JOUR.OUVRE(A1-1;1;fériés)

Dernier jour ouvré du mois

A1 contient le no de mois (1,2,3,..)

=SERIE.JOUR.OUVRE(DATE(2010;A1+1;1);-1;fériés)

Liste des Jours ouvrés entre 2 dates

JO2Dates
JO2Date2

D2: =MIN(SI((JOURSEM(B1+LIGNE($1:$7);2)<6)*(NB.SI(fériés;B1+LIGNE($1:$7))=0);B1+LIGNE($1:$7)))
Valider avec Maj+ctrl+entrée
D3: =SI(D2<>"";SI(D2+1<=$B$2;MIN(SI((JOURSEM(D2+LIGNE($1:$7);2)<6)*(NB.SI(fériés;D2+LIGNE($1:$7))=0);D2+LIGNE($1:$7)));"");"")
Valider avec Maj+ctrl+entrée

F2: =MIN(SI((JOURSEM(B1+LIGNE($1:$7);2)<6)*(JOURSEM(B1+LIGNE($1:$7);2)<>3)*(NB.SI(fériés;B1+LIGNE($1:$7))=0);B1+LIGNE($1:$7)))
Valider avec Maj+ctrl+entrée
F3: =SI(F2<>"";SI(F2+1<=$B$2;MIN(SI((JOURSEM(F2+LIGNE($1:$7);2)<6)*(JOURSEM(F2+LIGNE($1:$7);2)<>3)*(NB.SI(fériés;F2+LIGNE($1:$7))=0);
F2+LIGNE($1:$7)));"");"")
Valider avec Maj+ctrl+entrée

Liste des jours ouvrés entre 2 dates (B1 et B2) sans vacances

JO2DatesSans Vacances

=PETITE.VALEUR(SI((JOURSEM(LIGNE(INDIRECT($B$1&":"&$B$2));2)<6)* (NB.SI(fériés;
LIGNE(INDIRECT($B$1&":"&$B$2)))=0)*
(ESTNA(EQUIV(LIGNE(INDIRECT($B$1&":"&$B$2));LIGNE(INDIRECT(dvac1&":"&fvac1));0)))*
(ESTNA(EQUIV(LIGNE(INDIRECT($B$1&":"&$B$2));LIGNE(INDIRECT(dvac2&":"&fvac2));0)))*
(ESTNA(EQUIV(LIGNE(INDIRECT($B$1&":"&$B$2));LIGNE(INDIRECT(dvac3&":"&fvac3));0)));
LIGNE(INDIRECT($B$1&":"&$B$2)));LIGNE($1:$260))

Liste des jours fériés entre 2 dates

JF2Dates

-Sélectionner C2:M2
=SI(ESTNUM(PETITE.VALEUR(SI((NB.SI(fériés;LIGNE(INDIRECT(A2&":"&B2)))>0);LIGNE(INDIRECT(A2&":"&B2)));COLONNE($A:$K)));
PETITE.VALEUR(SI((NB.SI(fériés;LIGNE(INDIRECT(A2&":"&B2)))>0);LIGNE(INDIRECT(A2&":"&B2)));COLONNE($A:$K));"")
-Valider maj+ctrl+entrée

Planning jours ouvrés samedi

En C2:
=MIN(SI((JOURSEM(B2+LIGNE(1:6);2)<7)*(NB.SI(fériés;B2+LIGNE(1:6))=0)<>0;(B2+LIGNE(1:6))))
Valider avec maj+ctrl+entrée

PlanningJoursOuvrésSamedi

Calendriers

Calendrier mensuel

La cellule B3 contient le no de mois:1
La cellule I3 contient le no de mois:2

-Sélectionner A5:G10
=SI(MOIS(DATE($A$1;A3;1)-JOURSEM(DATE($A$1;A3;1);2)+{1.2.3.4.5.6.7}+{0;1;2;3;4;5}*7)=A3;
DATE($A$1;A3;1)-JOURSEM(DATE($A$1;A3;1);2)+{1.2.3.4.5.6.7}+{0;1;2;3;4;5}*7;"")
- Valider avec Maj+Ctrl+entrée

Calendrier mensuel
CalendrierTousMois
Calendriers
CalendrierXLD
CalendrierXLD2
Fêtes
Fêtes2
CalendrierEvenement
CalendrierAnnivFêtes
CalendrierEvenementFormule
CalendrierAnnuelBDVba
CalendrierAnnuelBDFormule

Calendrier annuel

Pour obtenir un calendrier annuel avec une seule formule.

-Sélectionner A4:L35
=SI(MOIS(DATE(an;COLONNE(1:12);LIGNE(1:31)))=COLONNE(1:12);DATE(an;COLONNE(1:12);LIGNE(1:31));"")
-valider avec Maj+Ctrl+entrée

- Calendrier Annuel -

Calendrier avec saisie de commentaires

Une synthèse annuelle est affichée.

CalendrierXLD1
CalendrierXLD2

Plannings

Colorie la cellule en fonction du caractère frappé

Les couleurs sont dégfinies dans un champ nommé Couleurs
- ColoriageSaisieLettre -

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    On Error Resume Next
    Target.Interior.ColorIndex = [couleurs].Find(Target, LookAt:=xlWhole).Interior.ColorIndex
  End If
End Sub

Planning avec barre d'outils

Sur cet exemple, une barre d'outils permet d'écrire dans un champ le type de congés.

Planning Coloriage Barre

Les couleurs du planning sont définies dans un champ Couleurs.

Dim Barre As CommandBar
Sub AfficheMenu()
  On Error Resume Next
  CommandBars("BarreColoriage").Delete
  On Error GoTo 0
  ReDim ListeShapes(1 To Sheets("couleurs").Shapes.Count)
  i = 1
  For Each s In Sheets("couleurs").Shapes
     ListeShapes(i) = s.Name: i = i + 1
  Next s
  Set Barre = Application.CommandBars.Add("barreColoriage", msoBarPopup)
  For b = 1 To UBound(ListeShapes)
     Sheets("couleurs").Shapes(ListeShapes(b)).Copy
     texte = Sheets("couleurs").Shapes(ListeShapes(b)).DrawingObject.Caption
     With Barre.Controls.Add(msoControlButton, 1, ListeShapes(b), , True)
        .PasteFace
        .Caption = Sheets("couleurs").Shapes(ListeShapes(b)).DrawingObject.Caption
        .OnAction = "Coloriage(" & b & ")"
     End With
   Next b
   Barre.ShowPopup
End Sub

Sub Coloriage(p)
  Application.ScreenUpdating = False
  couleur = Sheets("couleurs").Shapes(Barre.Controls(p).Parameter).Fill.ForeColor
  texte = Sheets("couleurs").Shapes(Barre.Controls(p).Parameter).DrawingObject.Caption
  If texte = "efface" Then texte = ""
  Selection.Interior.Color = couleur
  Selection.Value = texte
End Sub

Récupération de la couleur d'une liste

La couleur est modifiée après le choix dans la liste.
- DvListeRecupCouleur -

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    On Error Resume Next
    Target.Interior.ColorIndex = [couleurs].Find(Target, LookAt:=xlWhole).Interior.ColorIndex
  End If
End Sub

Planning mensuel

Dans ce planning, l'opérateur sélectionne le champ d'écriture puis choisit dans la barre d'outils le type d'activité.

PlanningMensuel Barre Boutons
Planning Panoramique BD
Planning Panoramique BD Matin/Après-Midi
Planning Panoramique BD JO
Planning Mensuel Form Boutons
Planning Panoramique BD 2
Planning Mensuel Barre Boutons 2009-2010
Planning Mensuel Barre Boutons 2010-2011

Les couleurs sont définies dans un champ MesCouleurs

Planning mensuel vertical

Calcul du numéro de semaine:
=SI(ESTNUM(ENT(MOD(ENT((C5-2)/7)+0,6;52+5/28))+1);ENT(MOD(ENT((C5-2)/7)+0,6;52+5/28))+1;"")

- PlanningVerticalMensuel - PlanningVerticalMensuel2

Planning avec Images

- Planning images -

Private Sub Worksheet_Change(ByVal Target As Range)
  If (Target.Column = 5 Or Target.Column = 7 _
     Or Target.Column = 9 Or Target.Column = 11 Or Target.Column = 13) _
        And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
       If s.Type = 13 Or s.Type = 1 Then
          If s.TopLeftCell.Address = Target.Offset(0, 1).Address Then
             s.Delete
          End If
       End If
    Next s
'--
    If Application.Match(Target, [maliste], 0) <> 6 Then
       Sheets("Liste").Shapes(Application.Substitute(Target, " ", "")).Copy
       Target.Offset(0, 1).Select
       ActiveSheet.Paste
       Selection.ShapeRange.Left = ActiveCell.Left + 5
       Selection.ShapeRange.Top = ActiveCell.Top + 4
       Target.Select
     End If
   End If
End Sub

Autre version

L'opérateur sélectionne le champ puis clique sur le bouton de la BO.

Planning Images2

En Excel>2003, la barre est située dans l'onglet Compléments.

Sub auto_open()
  On Error Resume Next
  CommandBars.Add ("BarreColoriage")
  CommandBars("BarreColoriage").Visible = True
  For i = 1 To [couleurs].Count
    Set bouton = CommandBars("BarreColoriage").Controls.Add(Type:=msoControlButton)
    bouton.Style = msoButtonCaption
    bouton.OnAction = "'Coloriage """ & i & """'"
    bouton.Caption = Range("couleurs")(i)
  Next i
End Sub

Sub Coloriage(p)
  m = Selection.Address
  For Each C In Selection
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Or s.Type = 1 Then
        If s.TopLeftCell.Address = C.Address Then s.Delete
      End If
    Next s
    If Application.Match(Range("couleurs")(p), [couleurs], 0) <> 6 Then
      Sheets("Couleurs").Shapes(Range("couleurs")(p)).Copy
      C.Select
      ActiveSheet.Paste
      Selection.ShapeRange.Left = ActiveCell.Left + 5
      Selection.ShapeRange.Top = ActiveCell.Top + 4
    End If
  Next C
  Range(m).Select
Calculate
End Sub

Sub auto_close()
   On Error Resume Next
   Application.CommandBars("BarreColoriage").Delete
End Sub

Fonction pour compter les images

Function CompteImages(champ As Range, nomImage)
  Application.Volatile
  For Each s In ActiveSheet.Shapes
    If Not Intersect(Range(s.TopLeftCell.Address), champ) Is Nothing Then
       If s.Name = nomImage Then n = n + 1
    End If
  Next
  CompteImages = n
End Function

Planning avec police WingDings

- Planning wingdings -

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect([C3:I14], Target) Is Nothing And Target.Count = 1 Then
Application.EnableEvents = False
p = Application.Match(Target, [MaListe], 0)
Sheets("ListeConges").Range("MaListe")(p).Offset(0, 1).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Target.PasteSpecial Paste:=xlValues
Application.EnableEvents = True
End If
End Sub

Autre version avec barre

L'opérateur sélectionne le champ puis clique sur le bouton de la BO. - Planning coloriage barre -

Sub auto_open()
  On Error Resume Next
  CommandBars.Add ("BarreColoriage")
  CommandBars("BarreColoriage").Visible = True
  For i = 1 To [couleurs].Count
    Set bouton = CommandBars("BarreColoriage").Controls.Add(Type:=msoControlButton)
    bouton.Style = msoButtonCaption
    bouton.Tag = i
    bouton.OnAction = "'Coloriage """ & bouton.Tag & """'"
    bouton.Caption = Range("couleurs")(i)
  Next i
End Sub

Sub Coloriage(p)
  For Each C In Selection
    If Not Intersect([planning], C) Is Nothing Then
      C.Value = Range("couleurs")(p).Value
      Sheets("Couleurs").Range("Couleurs")(p).Offset(0, 1).Copy C
    End If
  Next C
End Sub

Sub auto_close()
  On Error Resume Next
  Application.CommandBars("BarreColoriage").Delete
End Sub

Conversion de planning

Un planning Date/Activité/Nom est convertit en planning Nom/Date/Activité

PlanningTranspose

Le coloriage du nom se fait avec:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    On Error Resume Next
    Target.Font.ColorIndex = [ListeNoms].Find(Target, LookAt:=xlWhole).Font.ColorIndex
   End If
End Sub

Pour alimenter les listes déroulantes avec les personnes disponibles:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    [M2:M100].ClearContents
    For Each c In [ListeNoms]
      If IsError(Application.Match(c, Range(Cells(Target.Row, 2), Cells(Target.Row, 7)), 0)) Then
        [M65000].End(xlUp).Offset(1, 0) = c
      End If
    Next c
End If

Transposition du planning

La formule en B5 permet de transposer le planning:

=SI(ESTNA(EQUIV($A5;DECALER(PlanningAct!$B$4:$G$4;COLONNE()-2;0);0));"";INDEX(activité;EQUIV($A5;DECALER(PlanningAct!$B$4:$G$4;COLONNE()-2;0);0)))

Coloriage de l'activité

Private Sub Worksheet_Activate()
  For Each c In [Planning2]
    c.Interior.ColorIndex = xlNone
    On Error Resume Next
    c.Interior.ColorIndex = [activité].Find(c, LookAt:=xlWhole).Interior.ColorIndex
  Next c
End Sub

BD sous forme de planning

Format/MFC/La formule est:
=SOMMEPROD((Noms=$A3)*(B$2>=Début)*(B$2<=Fin))

PlanningBD

Autre version

En B3
=SI(SOMMEPROD((Noms=$A3)*(B$2>=Début)*(B$2<=Fin))>0;
INDEX(Taches;MIN(SI((Noms=$A3)*(B$2>=Début)*(B$2<=Fin);LIGNE(Taches)))-1);"")
Valider avec Maj+ctrl+entrée

ou

=SI(SOMMEPROD((Noms=$A3)*(B$2>=Début)*(B$2<=Fin))>0;
INDEX(Taches;SOMMEPROD((Noms=$A3)*(B$2>=Début)*(B$2<=Fin)*LIGNE(Noms))-1);"")

PlanningBD3
PlanBDCouleur
PlanningBD3Bis
PlanningBDSalles
PlanningBDSalles2
PlanningBDVéhicule
PlanningBDVéhicule2

Autre version

MFC en C4: =SOMMEPROD((B5>=Début)*(B5<=Fin)*(Noms=C$4)*(Etat="Accepte"))

CalendrierBDMFC

Autre version

PlanningBDAnnuel

Sub Creeplanning()
  Set planning = Sheets("planning")
  [B3:AG15].ClearComments
  [B3:AG15].Interior.ColorIndex = xlNone
  NomEntreprise = planning.[B1]
  For e = 1 To [entreprise].Count
    If UCase(Range("entreprise")(e)) = UCase(NomEntreprise) Then
      If Range("début")(e) <> "" Then
         jd = Day(Range("début")(e))
         md = Month(Range("début")(e))
         cmt = Range("client")(e)
         montant = Range("montant")(e)
         With planning.[B4].Offset(md - 1, jd)
          .AddComment
          .Comment.Shape.OLEFormat.Object.Font.Size = 7
          .Comment.Text Text:=cmt & Chr(10) & montant & " Ke"
          .Comment.Shape.TextFrame.AutoSize = True
          .Comment.Visible = True
        End With
        durée = Range("fin")(e) - Range("début")(e) + 1
        nbj = Day(DateSerial(planning.[A1], md + 1, 0))
        For d = 0 To durée - 1
          If jd + d <= nbj Then
            planning.Range("b3").Offset(md, jd + d).Interior.ColorIndex = 36
          Else
            planning.Range("b3").Offset(md + 1, jd + d - nbj).Interior.ColorIndex = 36
          End If
        Next d
      End If
    End If
  Next e
End Sub

CalendrierAnnuelBD

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$F$1" Then
    Application.ScreenUpdating = False
    For m = 1 To 12
      [C5:C35].Offset(, (m - 1) * 3).ClearContents
      [C5:C35].Offset(, (m - 1) * 3).Interior.ColorIndex = xlNone
    Next m
    Set planning = Sheets("calendrier")
    Set bd = Sheets("BD")
    NomEntreprise = [F1]
    For e = 1 To [entreprise].Count
      If UCase(bd.Range("entreprise")(e)) = UCase(NomEntreprise) _
         And bd.Range("accepte")(e) = "ACCEPTE" Then
         If bd.Range("début")(e) <> "" Then
           For d = bd.Range("début")(e) To bd.Range("fin")(e)
             j = Day(d)
             m = Month(d)
             Cells(4 + j, (m - 1) * 3 + 3) = bd.Range("client")(e)
             Cells(4 + j, (m - 1) * 3 + 3).Interior.ColorIndex = 36
          Next d
       End If
     End If
   Next e
End If
End Sub

Version avec Formule

CalendrierAnnuelBDFormule

=SI(SOMMEPROD((B5>=Début)*(B5<=Fin)*(Entreprise=$F$1)*(Etat="Accepte"))>0;INDEX(Client;MIN(SI((B5>=Début)*(B5<=Fin);LIGNE(Client)))-1);"")
Valider avec Maj+ctrl+entrée

Version multi-stages

=SI(SOMMEPROD((B5>=Début)*(B5<=Fin)*(Stage=C$4)*(Etat="Accepte"))>0;INDEX(Client;MIN(SI((B5>=Début)*(B5<=Fin)*(Stage=C$4);LIGNE(Client)))-1);"")

CalendrierAnnuelBDFormule2

Calendrier stages

CalendrierBDStagesVBA

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = False
  nstage = 11 ' nombre de stages
  For m = 1 To 5 ' nombre de mois
    [C5:M35].Offset(, (m - 1) * (nstage + 2)).ClearContents
    [C5:M35].Offset(, (m - 1) * (nstage + 2)).Interior.ColorIndex = xlNone
    [C5:M35].Offset(, (m - 1) * (nstage + 2)).ClearComments
  Next m
  Set planning = Sheets("calendrier")
  Set bd = Sheets("BD")
  For s = 1 To [Stage].Count
   If UCase(bd.Range("stage")(s)) <> "" Then
      If bd.Range("début")(s) <> "" And Year(bd.Range("début")(s)) = [An] Then
        j = Day(bd.Range("début")(s))
       m = Month(bd.Range("début")(s))
       With Cells(4 + j, (m - 1) * (nstage + 2) + 3 + s)
         .AddComment
         temp = bd.Range("lieu")(s) & Chr(10) & bd.Range("thème")(s)
         .Comment.Text Text:=temp
         .Comment.Shape.TextFrame.AutoSize = True
         .Comment.Visible = True
       End With
       For d = bd.Range("début")(s) To bd.Range("fin")(s)
         j = Day(d)
         m = Month(d)
         Cells(4 + j, (m - 1) * (nstage + 2) + 3 + s) = bd.Range("stage")(s)
         Cells(4 + j, (m - 1) * (nstage + 2) + 3 + s).Interior.ColorIndex = 36
       Next d
     End If
    End If
   Next s
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$A$2" Then
      Worksheet_Activate
    End If
End Sub

Version avec 10 stages/mois

CalendrierBDStagesVBA2

Autre présentation

Avec formule:
=SI(SOMMEPROD((Noms=$A4)*(B$2>=Début)*(B$2<=Fin))>0;
INDEX(Stages;MIN(SI((Noms=$A4)*(B$2>=Début)*(B$2<=Fin);LIGNE(Noms)))-1);"")

PlanningStages
PlanningStage2007

Avec VBA

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = False
  debPlan = DateSerial([année], 1, 1)
  Set fbd = Sheets("bd")
  Set fplan = Sheets("planSem1VBA")
  [B4:FZ23].ClearContents
  [B4:FZ23].Interior.ColorIndex = xlNone
  nblignes = fbd.[A1].CurrentRegion.Rows.Count
  For i = 2 To nblignes
    nom = fbd.Cells(i, 1)
    Set result = fplan.[A:A].Find(What:=nom, LookIn:=xlValues)
    If Not result Is Nothing Then
      If fbd.Cells(i, 3) < DateSerial([année], 7, 1) Then
        début = fbd.Cells(i, 2) - debPlan + 2
        fin = fbd.Cells(i, 3) - debPlan + 2
        Stage = fbd.Cells(i, 4)
        fplan.Cells(result.Row, début) = Stage
        lig = result.Row
        For d = début To fin
          fplan.Cells(result.Row, d).Interior.ColorIndex = 6
        Next d
      End If
    End If
  Next i
End Sub

Planning Mensuel BD

On choisi le mois à afficher dans une liste déroulante.

PlanningMensuelBD

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$2" Then
    Application.ScreenUpdating = False
    debPlan = DateSerial([année], [A2], 1)
    FinPlan = DateSerial([année], [A2] + 1, 1) - 1
    Set fbd = Sheets("bd")
    Set fplan = Sheets("plan")
    [B4:AF23].ClearContents
    [B4:AF23].Interior.ColorIndex = xlNone
    [B4:AF23].ClearComments
    nblignes = fbd.[A1].CurrentRegion.Rows.Count
    For i = 2 To nblignes
      nom = fbd.Cells(i, 1)
      Set result = fplan.[A:A].Find(What:=nom, LookIn:=xlValues)
      If Not result Is Nothing Then
         If fbd.Cells(i, 2) >= debPlan And fbd.Cells(i, 2) <= FinPlan Then
            début = fbd.Cells(i, 2) - debPlan + 2
            fin = fbd.Cells(i, 3) - debPlan + 2
            Stage = fbd.Cells(i, 4)
            fplan.Cells(result.Row, début) = Stage
            With fplan.Cells(result.Row, début)
              .AddComment
              .Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
               temp = fbd.Cells(i, 1) & vbLf
               temp = temp & fbd.Cells(i, 5)
              .Comment.Text Text:=temp
              .Comment.Shape.TextFrame.Characters(Start:=1, Length:=Len(fbd.Cells(i, 1))).Font.Bold = True
              .Comment.Shape.TextFrame.AutoSize = True
              .Resize(, fin - début + 1).Interior.ColorIndex = _
                 [couleurs].Find(Stage, LookAt:=xlWhole).Interior.ColorIndex
            End With
         End If
      End If
    Next i
  End If
End Sub

Planning Hebdo

MFC:=SOMMEPROD((noms=B$2)*(B$1+$A3>=dates+début)*(B$1+$A3<=dates+fin))

PlanningHebdo

Avec affichage des tâches

En B3
=SI(SOMME((noms=B$2)*(B$1+$A3>=dates+début)*(B$1+$A3<=dates+fin))>0;
INDEX(taches;MIN(SI((noms=B$2)*(B$1+$A3>=dates+début)*(B$1+$A3<=dates+fin);LIGNE(taches)))-1);"")
Valider avec Maj+ctrl+entrée

PlanningHebdoTâche

Autre exemple

PlanningJournalier

En B15:
=SI(SOMMEPROD((poste=$A15)*(B$14>=début)*(B$14<=fin))>0;
INDEX(EmpChoisis;SOMMEPROD((poste=$A15)*(B$14>=début)*(B$14<=fin)*LIGNE(INDIRECT("1:"&LIGNES(poste)))));"")

Création d'une BD à partir d'un planning

PlanningBD6

Private Sub Worksheet_Activate()
  Set f = Sheets("Planning 2009")
  [A2:D1000].ClearContents
  For Each c In f.Cells.SpecialCells(xlCellTypeAllValidation)
    If c.Value <> "" Then
      [A65000].End(xlUp).Offset(1) = f.Cells(c.Row, 1)
      [A65000].End(xlUp).Offset(, 1) = f.Cells(1, c.Column)
      [A65000].End(xlUp).Offset(, 2) = c.Value
      If Not c.Comment Is Nothing Then
         temp = c.Comment.Text
         p = InStr(temp, ":")
         If p <> 0 Then temp = Mid(temp, p + 1)
            [A65000].End(xlUp).Offset(, 3) = temp
         End If
       End If
   Next c
End Sub

Autre exemple

PlanningPanoramiqueBD

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = False
  Set s = Sheets("BD")
  s.[A2:E1000].ClearContents
  For sem = 1 To 2
    Set p = Sheets("sem" & sem)
    nbCol = 190
    For ligne = 4 To 23
    i = 2
    Do While i <= nbCol
      témoin = False
      Do While p.Cells(ligne, i) = "" And i <= nbCol
         If i = nbCol Then témoin = True
         i = i + 1
      Loop
      If Not témoin Then
         typeCongés = p.Cells(ligne, i)
         début = p.Cells(2, i)
         Do While p.Cells(ligne, i) = typeCongés And i <= nbCol
           If i = nbCol Then témoin = True
              i = i + 1
         Loop
         fin = p.Cells(2, i - 1)
         ligneBD = s.[A65000].End(xlUp).Row + 1
         s.Cells(ligneBD, 1) = p.Cells(ligne, 1)
         s.Cells(ligneBD, 2) = début
         s.Cells(ligneBD, 3) = fin
         s.Cells(ligneBD, 4) = typeCongés
         s.Cells(ligneBD, 5) = fin - début + 1
       End If
      Loop
    Next ligne
  Next sem
End Sub

Création du planning à partir de la BD

Sub CreePlan()
  Application.ScreenUpdating = False
  Set bd = Sheets("bd")
  For lig = 2 To [A65000].End(xlUp).Row
    nom = bd.Cells(lig, 1)
    début = bd.Cells(lig, 2)
    fin = bd.Cells(lig, 3)
    typeConges = bd.Cells(lig, 4)
    If Month(début) < 7 Then Set p = Sheets("sem1") Else Set p = Sheets("sem2")
    Set temp = p.[A:A].Find(what:=nom)
    If Not temp Is Nothing Then
      ligPlan = temp.Row
      n = fin - début + 1
      Application.EnableEvents = False
      [Couleurs].Find(typeConges, LookAt:=xlWhole).Copy
      For i = 0 To n - 1
        If Month(début + i) < 7 Then Set p = Sheets("sem1") Else Set p = Sheets("sem2")
        d = début - p.Cells(2, 2) + 2
        p.Cells(ligPlan, d + i) = typeConges
        p.Cells(ligPlan, d + i).PasteSpecial Paste:=xlPasteFormats
      Next i
      Application.EnableEvents = True
    End If
   Next lig
End Sub

Création de plannings individuels à partir de la BD

Sub CreePlanIndividuel()
  Set planning = Sheets("planIndiv")
  Set bd = Sheets("BD")
  planning.[c4:AG15].ClearComments
  planning.[c4:AG15].ClearContents
  planning.[c4:AG15].Interior.ColorIndex = xlNone
  Nom = planning.[B1]
  For lig = 2 To bd.[A65000].End(xlUp).Row
     If UCase(bd.Cells(lig, 1)) = UCase(Nom) Then
        If bd.Cells(lig, 2) <> "" Then
          jd = Day(bd.Cells(lig, 2))
          md = Month(bd.Cells(lig, 2))
          typeConges = bd.Cells(lig, 4)
          durée = bd.Cells(lig, 3) - bd.Cells(lig, 2) + 1
          nbj = Day(DateSerial(planning.[A1], md + 1, 0))
          For d = 0 To durée - 1
            If jd + d <= nbj Then
               planning.Range("b3").Offset(md, jd + d).Interior.ColorIndex = _
               Sheets("fériés").[Couleurs].Find(typeConges, LookAt:=xlWhole).Interior.ColorIndex
               planning.Range("b3").Offset(md, jd + d) = typeConges
            Else
               planning.Range("b3").Offset(md + 1, jd + d - nbj).Interior.ColorIndex = _
               Sheets("fériés").[Couleurs].Find(typeConges, LookAt:=xlWhole).Interior.ColorIndex
               planning.Range("b3").Offset(md + 1, jd + d - nbj) = typeConges
           End If
        Next d
      End If
    End If
  Next lig
End Sub

Sub CreeOnglets()
  Application.ScreenUpdating = False
  supOnglets
  Set bd = Sheets("bd")
  bd.[A1].CurrentRegion.Sort Key1:=bd.Range("A2"), Order1:=xlAscending, Header:=xlGuess
  ligBD = 2
  Do While ligBD <= bd.[A65000].End(xlUp).Row
    Nom = bd.Cells(ligBD, 1) ' Premier nom
    Sheets("modèle").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "F_" & Nom
    Set plan = Sheets("F_" & Nom)
    plan.[E7:L8] = plan.[E7:L8].Value
    plan.Range("D5").Value = Nom
    ligPlan = 9
    Do While bd.Cells(ligBD, 1) = Nom 'parcours nom traité
       typeConges = bd.Cells(ligBD, 4)
       jours = bd.Cells(ligBD, 5)
       plan.Cells(ligPlan, 3) = bd.Cells(ligBD, 2)
       plan.Cells(ligPlan, 4) = bd.Cells(ligBD, 3)
       p = Application.Match(typeConges, Sheets("fériés").[Couleurs], 0)
       If Not IsError(p) Then plan.Cells(ligPlan, p + 4) = jours
       ligBD = ligBD + 1
       ligPlan = ligPlan + 1
     Loop
   Loop
End Sub

Sub supOnglets()
  Application.DisplayAlerts = False
  For s = Sheets.Count To 1 Step -1
    If Left(Sheets(s).Name, 2) = "F_" Then Sheets(s).Delete
  Next s
End Sub

Autre exemple

PLanPanoramiqueSynthèse

Private Sub Worksheet_Activate()
  [A1:M100].ClearContents
  [A2:M100].Interior.ColorIndex = xlNone
  [couleurs].Copy
  [B1].PasteSpecial Paste:=xlPasteAll, Transpose:=True
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  lignedep = 2
  ligne = 2
  For i = 1 To 20
    Cells(ligne, 1) = Sheets("plansem1").[A4].Offset(i - 1)
    For Each s In Array("plansem1", "plansem2")
      Set f = Sheets(s)
      For Each c In f.[b4].Offset(i - 1).Resize(, 190)
        If c <> "" Then
          col = [1:1].Find(c).Column
          lg = lignedep: témoin = False
          Do While lg <= ligne And Not témoin
            If Cells(lg, col) = "" Then
              Cells(lg, col) = f.Cells(2, c.Column)
              Cells(lg, col).Interior.ColorIndex = Cells(1, col).Interior.ColorIndex
              témoin = True
            Else
              lg = lg + 1
            End If
         Loop
         If Not témoin Then
           ligne = ligne + 1
           Cells(ligne, col) = f.Cells(2, c.Column)
           Cells(ligne, col).Interior.ColorIndex = Cells(1, col).Interior.ColorIndex
          End If
        End If
      Next c
    Next s
    ligne = ligne + 2
    lignedep = ligne
  Next i
  Application.Calculation = xlAutomatic
End Sub

Vacances scolaires

Vacances

Planning de tâches

En E4:=SI(ET(E$3>=$C4;E$3<$C4+$D4);$B4;"")

PlanTâches

Le coloriage du planning se fait avec

Private Sub Worksheet_Calculate()
  Application.ScreenUpdating = False
  For Each c In [zoneMFC]
    c.Interior.ColorIndex = xlNone
    If c.Value <> "" Then
      On Error Resume Next
      c.Interior.ColorIndex = [Couleurs].Find(c.Value, LookAt:=xlWhole).Interior.ColorIndex
      c.Font.ColorIndex = [Couleurs].Find(c.Value, LookAt:=xlWhole).Font.ColorIndex
    End If
  Next c
End Sub

Synthèse d'une BD sous forme de planning

Pour un code, il y a plusieurs dates par mois.

PlanBdMois

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = False
  Set fbd = Sheets("bd")
  [A2:M10].ClearContents
  For i = 2 To fbd.[A65000].End(xlUp).Row
    code = fbd.Cells(i, 1)
    dt = fbd.Cells(i, 2)
    Set result = [A:A].Find(What:=code, LookIn:=xlValues)
    If result Is Nothing Then
       ligne = [A65000].End(xlUp).Row + 1
       Cells(ligne, 1) = code
    Else
       ligne = result.Row
    End If
    If Cells(ligne, Month(dt) + 1) = "" Then
      Cells(ligne, Month(dt) + 1) = dt
    Else
      Cells(ligne, Month(dt) + 1) = Cells(ligne, Month(dt) + 1) & vbLf & dt
    End If
  Next i
End Sub

Planification de salles

Une salle ne peut être affectée 2 fois le même jour. Dans le menu déroulant des salles n'apparaissent que les salles disponibles.

PlanifSalles
PlanningBDVéhicule2

Le conflits de dates sont signalées par MFC

=(SOMMEPROD(($A2>=début)*($A2<=fin)*($C2=PlanSalles))>1)*($A2<>"")
=(SOMMEPROD(($B2>=début)*($B2<=fin)*($C2=PlanSalles))>1)*($A2<>"")
=(SOMMEPROD(($A2<=début)*($B2>=fin)*($C2=PlanSalles))>1)*($A2<>"")

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([C2:C200], Target) Is Nothing And Target.Count = 1 Then
    début = Cells(Target.Row, 1)
    fin = Cells(Target.Row, 2)
    If début > 0 And fin > 0 Then
      Set mondico = CreateObject("Scripting.Dictionary")
      For ligne = 2 To 100
        If (début >= Cells(ligne, 1) And début <= Cells(ligne, 2)) Or _
           (fin >= Cells(ligne, 1) And fin <= Cells(ligne, 2)) Or _
             (début <= Cells(ligne, 1) And fin >= Cells(ligne, 2)) Then
              temp = Cells(ligne, 3)
              mondico(temp) = temp
        End If
        [I2:I100].ClearContents
        For Each c In [Salles]
          If Not mondico.Exists(c.Value) Then
             [I65000].End(xlUp).Offset(1) = c
          End If
       Next c
     Else
        [I2:I100].ClearContents
     End If
   End If
End Sub

Un planning visuel est obtenu par formule matricielle

=SI((SOMMEPROD((PlanSalles=$A4)*(D$3>=début)*(D$3<=fin))>0)*($A4>0);INDEX(PlanStages;MIN(SI((PlanSalles=$A4)*(D$3>=début)*(D$3<=fin);LIGNE(PlanStages)))-1);"")

Planification de véhicules

Unvéhicule ne peut être affecté 2 fois dans la même période. Dans le menu déroulant des véhicules n'apparaissent que les véhicules disponibles.

PlanifVéhicules
PlanifVéhicules3
PlanningBDVéhicule2

Pour obtenir un planning visuel

=SI((SOMMEPROD((véhic=B$1)*($A2>=début)*($A2<=fin+0,000001))>0)*(B$1>0);INDEX(Noms;MIN(SI((véhic=B$1)*($A2>=début)*($A2<=fin+0,000001);LIGNE(véhic)))-1);"")

Planning avec double affectation(stage+salle)

Sur cet exemple, on affecte des stages et des salles. Une salle ne peut être affectée plusieurs fois à la même date.

PlanningStageSalles

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  UserForm1.Top = 110
  UserForm1.Left = 150
  UserForm1.Show
  Cancel = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Not Intersect([planning], Target) Is Nothing Then
      col1 = Target.Column
      ligne1 = [planning].Row
      Set mondico = CreateObject("Scripting.Dictionary")
      On Error Resume Next
      For Each c In Cells(ligne1, col1).Resize([planning].Rows.Count, Target.Columns.Count).SpecialCells(xlCellTypeComments)
        temp = Trim(c.Comment.Text)
        mondico(temp) = temp
      Next c
      UserForm1.ComboBox2.Clear
      For Each c In [ListeSalles]
         If Not mondico.Exists(c.Value) Then UserForm1.ComboBox2.AddItem c
      Next c
   sEnd If
End Sub

Private Sub B_ok_Click()
  If Me.ComboBox1 = "" Then Exit Sub
   For Each c In Selection
      c.Value = Me.ComboBox1
      c.Interior.ColorIndex = [listestages].Find(Me.ComboBox1).Interior.ColorIndex
      c.Font.ColorIndex = [listestages].Find(Me.ComboBox1).Font.ColorIndex
      If Me.ComboBox2 <> "" Then
         If Not c.Comment Is Nothing Then c.Comment.Delete
         c.AddComment
         c.Comment.Text Text:=Me.ComboBox2.Value
         c.Comment.Shape.TextFrame.AutoSize = True
       End If
    Next
End Sub

Private Sub UserForm_Initialize()
Me.ComboBox1.List = [listestages].Value
Me.ComboBox2.List = [ListeSalles].Value
End Sub

Pour obtenir le planning des salles automatiquement:

Private Sub Worksheet_Activate()
  Application.ScreenUpdating = False
  [planSalles].ClearContents
  [planSalles].ClearComments
  [planSalles].Interior.ColorIndex = xlNone
  For Each c In [planning]
    If Not c.Comment Is Nothing Then
       temp = Trim(c.Comment.Text)
      Set result = [A6:A24].Find(what:=temp, LookIn:=xlValues)
      If Not result Is Nothing Then
        Cells(result.Row, c.Column) = c.Value
        temp = Sheets("planning").Cells(c.Row, 1)
        If temp <> "" Then
          Cells(result.Row, c.Column).AddComment
          Cells(result.Row, c.Column).Comment.Text Text:=temp
          Cells(result.Row, c.Column).Comment.Shape.TextFrame.AutoSize = True
        End If
        Cells(result.Row, c.Column).Interior.ColorIndex = [listeStages].Find(c.Value).Interior.ColorIndex
        Cells(result.Row, c.Column).Font.ColorIndex = [listeStages].Find(c.Value).Font.ColorIndex
      End If
    End If
  Next
End Sub

Plannning semaine

Permet de créer un planning de 52 semaines.

Planning semaine

Saisie d'une date dans le tableur

CalendrierTableur1Date
CalendrierTableur1DateMicrosoft
CalendrierTableur2Dates
CalendrierForm1Date
CalendrierForm2Dates
CalendrierForm2DatesExemple
Filtre entre 2 dates calendrier

Le formulaire peut être exporté puis importé dans un autre classeur
-Alt+F11 puis clic-droit sur F_calendrier1dateTableur
-Exporter

Ce calendrier est portable:il ne nécessite pas d'installation particulière ou de fichier ocx.
Il indique les nos de semaine et les jours fériés.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Address = "$B$4" Then
    F_calendrier1dateTableur.Show
  End If
  Cancel = True
End Sub

Pour la saisie dans le champ C5:C10

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect([C5:C10], Target) Is Nothing Then
     F_calendrier1dateTableur.Show
  End If
  Cancel = True
End Sub

Version avec heure

CalendrierHeureTableur

Saisie de Date début et Date fin dans un tableau 2 colonnes

-Afficher le formulaire calendrier (double-clic)
-Cliquer sur la cellule dans la colonne Date début
-Choisir la Date début dans le calendrier
-Choisir Date Fin dans le calendrier
-Ok

Calendrier2Dates

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  F_calendrier2datesTableur.Show
  Cancel = True
End Sub

Le formulaire peut être exporté puis importé dans un autre classeur
-Alt+F11 puis clic-droit sur F_calendrier2datesTableur
-Exporter

Le calendrier Microsoft :
-ne permet pas de choisir un intervalle de dates
-ne donne pas les jours fériés

Formulaire de saisie BD avec dates

FormSaisie2dates
FormSaisie2dates2

Private Sub UserForm_Initialize()
  With Sheets("Listes")
    Me.Lieu.List = .Range("a2:A" & .Range("A65000").End(xlUp).Row).Value
    Me.Thème.List = .Range("b2:b" & .Range("b65000").End(xlUp).Row).Value
  End With
  F_calendrier2dates.Show
  F_calendrier2dates.Left = 190
  F_calendrier2dates.Top = 170
End Sub

Private Sub B_ok_dates_Click()
   Me.début = F_calendrier2dates.date_début
   Me.fin = F_calendrier2dates.date_fin
End Sub

Private Sub B_ok2_Click()
   If Me.Stage = "" Then
      MsgBox "Stage!"
      Me.Stage.SetFocus
      Exit Sub
  End If
  If Me.Lieu = "" Then
    MsgBox "Lieu!"
    Me.Lieu.SetFocus
    Exit Sub
  End If
  If Not IsDate(Me.début) Or Not IsDate(Me.fin) Then
     MsgBox "Dates!"
     Exit Sub
  End If
  With Sheets("BD")
    ligne = .Range("A65000").End(xlUp).Row + 1
    .Cells(ligne, 1) = Me.Stage
    .Cells(ligne, 2) = Me.Lieu
    .Cells(ligne, 3) = Me.Thème
    .Cells(ligne, 4) = CDate(Me.début)
    .Cells(ligne, 5) = CDate(Me.fin)
  End With
  Me.Stage = ""
  Me.Lieu = ""
  Me.Thème = ""
  Me.début = ""
  Me.fin = ""
End Sub

Private Sub B_fin_Click()
   Unload F_calendrier2dates
   Unload Me
End Sub

Formulaire avec calendrier inclus

Ce formulaire peut être complété. Les dates sont récupérées dans date_début et date_fin

FormCalendrierInclus
FormCalendrierInclus2dates

Filtre entre 2 dates à partir d'un formulaire

FiltreAuto2Dates

Private Sub Bfiltre_Click()
  If Not IsDate(Me.date_début) Or Not IsDate(Me.date_fin) Then Exit Sub
  [A1].AutoFilter Field:=3, Criteria1:=">=" & Format(CDate(Me.date_début), "mm/dd/yy"), _
     Operator:=xlAnd, Criteria2:="<=" & Format(CDate(Me.date_fin), "mm/dd/yy")
End Sub

Private Sub Btout_Click()
  On Error Resume Next
  ActiveSheet.ShowAllData
End Sub

Planning avec choix d'une photo dans un listbox

Les photos d'origine sont dans des commentaires

ListBoxPhotoInterneCommentaire

Ce programme exporte les photos en commentaire sous forme de JPG dans un répertoire c:\photos\

Sub auto_open()
  répertoirePhotos = "c:\photos\"    ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    c.Comment.Visible = True
    H = c.Comment.Shape.Height
    L = c.Comment.Shape.Width
    c.Comment.Shape.CopyPicture
    c.Comment.Visible = False
    f.ChartObjects.Add(0, 0, L, H).Chart.Paste
    f.ChartObjects(1).Border.LineStyle = 0
    f.ChartObjects(1).Chart.Export Filename:= _
       répertoirePhotos & c & ".jpg", FilterName:="jpg"
    f.ChartObjects(1).Delete
  Next c
  UserForm1.Show
End Sub

Code du formulaire

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, répertoirePhotos
Private Sub UserForm_Initialize()
  début = 1
  n = 3
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [Liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  répertoirePhotos = "c:\photos\" ' Adapter
  For i = 1 To n
     nom = Range("liste").Cells(i + début - 1, 1)
     Me("Image" & i).Picture = LoadPicture(répertoirePhotos & Range("liste").Cells(i + début - 1, 1) & ".jpg")
     Me("Image" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1)
     Me("Image" & i).BorderStyle = 0
     Me("Label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Sub ChoixClick(p, nom)
   For i = 1 To n
     Me("Image" & i).BorderStyle = 0
   Next i
   Me("Image" & p).BorderStyle = 1
   Set sel = Selection
   For Each c In Selection
     c.Value = nom
     Liste].Find(c.Value, LookAt:=xlWhole).Copy
     c.PasteSpecial Paste:=xlPasteFormats
     c.PasteSpecial Paste:=xlPasteComments
   Next c
   sel.Select
End Sub

Private Sub Image1_Click()
  ChoixClick 1, Me.Image1.ControlTipText
End Sub

Private Sub Image2_Click()
  ChoixClick 2, Me.Image2.ControlTipText
End Sub

Private Sub Image3_Click()
   ChoixClick 3, Me.Image3.ControlTipText
End Sub

Private Sub Label1_Click()
  ChoixClick 1, Me.Label1.Caption
End Sub

Private Sub Label2_Click()
ChoixClick 2, Me.Label2.Caption
End Sub

Private Sub Label3_Click()
ChoixClick 3, Me.Label3.Caption
End Sub

Les photos sont externes

ListBoxPhotoExterne

Les photos sont internes au classeur, encapsulées dans des images BO contrôles

ListBoxPhotoInterne