XL 2021 afficher nom dans un planning

M

malbae

XLDnaute Nouveau
Bonsoir,
Je souhaite afficher dans le calendrier le nom sur l'ensemble de la période concernée (arrivée/départ ds feuille réservation)
Pour l'instant le nom n’apparait que sur la date arrivée...
Pour info la couleur verte est une MFC

Merci pour vos lumières et bonne soirée
Paul
 

Pièces jointes

  • planning.xlsx
    31.5 KB · Affichages: 12
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonsoir malbae,

Une solution VBA avec cette macro dans le code de la feuille "Calendrier" :
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Set r = Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35")
r = "=IFERROR(VLOOKUP(DATE($D$2,B$3,$A5),resa2,5,0),"""")"
For Each r In r
    If r.DisplayFormat.Interior.Color <> vbWhite And r = "" Then r = r(0)
Next r
End Sub
Elle se déclenche quand on active la feuille.

Bonne nuit.
 

Pièces jointes

  • planning VBA.xlsm
    38 KB · Affichages: 3
Vote positif 0 Vote négatif
M

malbae

XLDnaute Nouveau
job75 à dit:
Bonsoir malbae,

Une solution VBA avec cette macro dans le code de la feuille "Calendrier" :
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Set r = Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35")
r = "=IFERROR(VLOOKUP(DATE($D$2,B$3,$A5),resa2,5,0),"""")"
For Each r In r
    If r.DisplayFormat.Interior.Color <> vbWhite And r = "" Then r = r(0)
Next r
End Sub
Elle se déclenche quand on active la feuille.

Bonne nuit.
Cliquez pour agrandir...
Bonsoir
Merci cela fonctionne parfaitement
Bonne nuit également
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Encore une chose : il faut effacer la formule pour les 30 et 31 février, 31 avril, 31 juin etc... :
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Set r = Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35")
r = "=IFERROR(VLOOKUP(DATE($D$2,B$3,$A5),resa2,5,0),"""")"
For Each r In r
    If r.DisplayFormat.Interior.Color <> vbWhite And r = "" Then r = r(0)
    If r(1, 0) = "" Then r = "" 'pour les 30 et 31 février etc...
Next r
End Sub
 

Pièces jointes

  • planning VBA.xlsm
    38.2 KB · Affichages: 2
Vote positif 0 Vote négatif
M

malbae

XLDnaute Nouveau
job75 à dit:
Encore une chose : il faut effacer la formule pour les 30 et 31 février, 31 avril, 31 juin etc... :
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Set r = Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35")
r = "=IFERROR(VLOOKUP(DATE($D$2,B$3,$A5),resa2,5,0),"""")"
For Each r In r
    If r.DisplayFormat.Interior.Color <> vbWhite And r = "" Then r = r(0)
    If r(1, 0) = "" Then r = "" 'pour les 30 et 31 février etc...
Next r
End Sub
Cliquez pour agrandir...
Ok
En revanche si je sélectionne une autre année (ex 2023) cela ne fonctionne pas.
Merci
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
malbae à dit:
En revanche si je sélectionne une autre année (ex 2023) cela ne fonctionne pas.
Cliquez pour agrandir...
Oui il faut ajouter une macro Worksheet_Change ;
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set r = Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35")
r = "=IFERROR(VLOOKUP(DATE($D$2,B$3,$A5),resa2,5,0),"""")"
For Each r In r
    If r.DisplayFormat.Interior.Color <> vbWhite And r = "" Then r = r(0)
    If r(1, 0) = "" Then r = "" 'pour les 30 et 31 février etc...
Next r
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub
Maintenant au lit.
 

Pièces jointes

  • planning VBA.xlsm
    38.3 KB · Affichages: 5
Vote positif 0 Vote négatif
M

malbae

XLDnaute Nouveau
job75 à dit:
Oui il faut ajouter une macro Worksheet_Change ;
VB: 
Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set r = Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35")
r = "=IFERROR(VLOOKUP(DATE($D$2,B$3,$A5),resa2,5,0),"""")"
For Each r In r
    If r.DisplayFormat.Interior.Color <> vbWhite And r = "" Then r = r(0)
    If r(1, 0) = "" Then r = "" 'pour les 30 et 31 février etc...
Next r
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub
Maintenant au lit.
Cliquez pour agrandir...
Parfait ;)
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour malbae, le forum,

Non la méthode précédente n'est pas parfaite car les périodes à cheval sur 2 mois et surtout sur 2 années ne sont pas traitées correctement.

Utilisez le fichier joint avec cette solution :
VB: 
Private Sub Worksheet_Activate()
Dim An%, tablo, i&, dat1 As Variant, dat2 As Variant, nom$, dat&
An = Val([D2])
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35") = "" 'RAZ
If An > 0 Then
    tablo = [resa].Resize(, 9) 'tableau structuré
    For i = 1 To UBound(tablo)
        dat1 = tablo(i, 5): dat2 = tablo(i, 6): nom = tablo(i, 9)
        If IsDate(dat1) And IsDate(dat2) Then
            If Year(dat1) = An Or Year(dat2) = An Then
                dat1 = Application.Max(CLng(CDate(dat1)), DateSerial(An, 1, 1))
                dat2 = Application.Min(CLng(CDate(dat2)), DateSerial(An, 12, 31))
                For dat = dat1 To dat2
                    Cells(4 + Day(dat), 1 + 2 * Month(dat)) = nom
                Next dat
            End If
        End If
    Next i
End If
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub
A+
 

Pièces jointes

  • planning VBA.xlsm
    37.7 KB · Affichages: 4
Vote positif 0 Vote négatif
M

malbae

XLDnaute Nouveau
job75 à dit:
Bonjour malbae, le forum, Non la méthode précédente n'est pas parfaite car les périodes à cheval sur 2 mois et surtout sur 2 années ne sont pas traitées correctement. Utilisez le fichier joint avec cette solution :
VB: 
Private Sub Worksheet_Activate() Dim An%, tablo, i&, dat1 As Variant, dat2 As Variant, nom$, dat& An = Val([D2]) Application.ScreenUpdating = False Application.EnableEvents = False 'désactive les évènements Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35") = "" 'RAZ If An > 0 Then tablo = [resa].Resize(, 9) 'tableau structuré For i = 1 To UBound(tablo) dat1 = tablo(i, 5): dat2 = tablo(i, 6): nom = tablo(i, 9) If IsDate(dat1) And IsDate(dat2) Then If Year(dat1) = An Or Year(dat2) = An Then dat1 = Application.Max(CLng(CDate(dat1)), DateSerial(An, 1, 1)) dat2 = Application.Min(CLng(CDate(dat2)), DateSerial(An, 12, 31)) For dat = dat1 To dat2 Cells(4 + Day(dat), 1 + 2 * Month(dat)) = nom Next dat End If End If Next i End If Application.EnableEvents = True 'réactive les évènements End Sub Private Sub Worksheet_Change(ByVal Target As Range) Worksheet_Activate 'lance la macro End Sub
A+
Cliquez pour agrandir...
job75 à dit:
Bonjour malbae, le forum,

Non la méthode précédente n'est pas parfaite car les périodes à cheval sur 2 mois et surtout sur 2 années ne sont pas traitées correctement.

Utilisez le fichier joint avec cette solution :
VB: 
Private Sub Worksheet_Activate()
Dim An%, tablo, i&, dat1 As Variant, dat2 As Variant, nom$, dat&
An = Val([D2])
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Range("C5:C35,E5:E35,G5:G35,I5:I35,K5:K35,M5:M35,O5:O35,Q5:Q35,S5:S35,U5:U35,W5:W35,Y5:Y35") = "" 'RAZ
If An > 0 Then
    tablo = [resa].Resize(, 9) 'tableau structuré
    For i = 1 To UBound(tablo)
        dat1 = tablo(i, 5): dat2 = tablo(i, 6): nom = tablo(i, 9)
        If IsDate(dat1) And IsDate(dat2) Then
            If Year(dat1) = An Or Year(dat2) = An Then
                dat1 = Application.Max(CLng(CDate(dat1)), DateSerial(An, 1, 1))
                dat2 = Application.Min(CLng(CDate(dat2)), DateSerial(An, 12, 31))
                For dat = dat1 To dat2
                    Cells(4 + Day(dat), 1 + 2 * Month(dat)) = nom
                Next dat
            End If
        End If
    Next i
End If
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub
A+
Cliquez pour agrandir...
Bonjour
Ca marche nickel !
Merci encore
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour malbae, le forum,

Toujours dans le code de la feuille :
VB: 
Private Sub Worksheet_Activate()
Dim An%, tablo, i&, dat1 As Variant, dat2 As Variant, nom$, dat&
An = Val([C2])
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Range("B6:AF6,B8:AF8,B10:AF10,B12:AF12,B14:AF14,B16:AF16,B18:AF18,B20:AF20,B22:AF22,B24:AF24,B26:AF26,B28:AF28") = "" 'RAZ
If An > 0 Then
    tablo = [resa].Resize(, 9) 'tableau structuré
    For i = 1 To UBound(tablo)
        dat1 = tablo(i, 5): dat2 = tablo(i, 6): nom = tablo(i, 9)
        If IsDate(dat1) And IsDate(dat2) Then
            If Year(dat1) = An Or Year(dat2) = An Then
                dat1 = Application.Max(CLng(CDate(dat1)), DateSerial(An, 1, 1))
                dat2 = Application.Min(CLng(CDate(dat2)), DateSerial(An, 12, 31))
                For dat = dat1 To dat2
                    Cells(4 + 2 * Month(dat), 1 + Day(dat)) = nom
                Next dat
            End If
        End If
    Next i
End If
Columns("B:AF").AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub
J'ai simplifié les MFC =B6<>"" et =C5<>"" sur l'autre calendrier.

A+
 

Pièces jointes

  • planning VBA(new).xlsm
    46.3 KB · Affichages: 11
Vote positif 0 Vote négatif
M

malbae

XLDnaute Nouveau
job75 à dit:
Bonjour malbae, le forum,

Toujours dans le code de la feuille :
VB: 
Private Sub Worksheet_Activate()
Dim An%, tablo, i&, dat1 As Variant, dat2 As Variant, nom$, dat&
An = Val([C2])
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Range("B6:AF6,B8:AF8,B10:AF10,B12:AF12,B14:AF14,B16:AF16,B18:AF18,B20:AF20,B22:AF22,B24:AF24,B26:AF26,B28:AF28") = "" 'RAZ
If An > 0 Then
    tablo = [resa].Resize(, 9) 'tableau structuré
    For i = 1 To UBound(tablo)
        dat1 = tablo(i, 5): dat2 = tablo(i, 6): nom = tablo(i, 9)
        If IsDate(dat1) And IsDate(dat2) Then
            If Year(dat1) = An Or Year(dat2) = An Then
                dat1 = Application.Max(CLng(CDate(dat1)), DateSerial(An, 1, 1))
                dat2 = Application.Min(CLng(CDate(dat2)), DateSerial(An, 12, 31))
                For dat = dat1 To dat2
                    Cells(4 + 2 * Month(dat), 1 + Day(dat)) = nom
                Next dat
            End If
        End If
    Next i
End If
Columns("B:AF").AutoFit 'ajustement largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub
J'ai simplifié les MFC =B6<>"" et =C5<>"" sur l'autre calendrier.

A+
Cliquez pour agrandir...
Merci beaucoup et bonne brise printanière
 
Vote positif 0 Vote négatif

Discussions similaires

C
  • Résolu(e)
XL 2021 Peut-on appliquer la mise en forme d'une MFC à plusieurs cellules ?
Réponses
2
Affichages
97
Constantin
C
A
  • Question
Microsoft 365 Planning automatique
Réponses
0
Affichages
227
Aboly
A
halecs93
  • Résolu(e)
XL 2016 Copie transposée de planning
2
Réponses
24
Affichages
425
job75
job75
S
  • Question
Microsoft 365 comment afficher une images dans INCORPORER("Forms.Image.1";"") avec une Clique de la souris
Réponses
1
Affichages
231
fanch55
fanch55
nadem0068
  • Question
XL 2019 période couplé avec un nom
Réponses
4
Affichages
214
nadem0068
nadem0068
T
  • Résolu(e)
XL 2016 comment mettre sur pieds un tableau de bord à partir des données d'un planning annuel
Réponses
9
Affichages
516
therse
T
W
  • Question
XL 2016 calcul tarif en fonction de différente saison
Réponses
4
Affichages
452
webermael
W
M
  • Résolu(e)
Microsoft 365 Code incomplet
5 6 7
Réponses
93
Affichages
2 K
Marvin57
M
H
  • Question
Microsoft 365 planning sur Excel
Réponses
0
Affichages
375
huzz
H
misteryann
  • Question
XL 2016 (RESOLU) Planning de réservation perpétuel
Réponses
5
Affichages
440
misteryann
misteryann

Membres actuellement en ligne

18 membres et 129 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 243
Messages
2 086 549
Membres
103 244
dernier inscrit
lavitzdecreu