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: 14
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: 4
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: 6
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: 5
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: 13
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

T
  • Résolu(e)
XL 2019 Planning hebdomadaire de réservation de salle
Réponses
14
Affichages
489
telemarrk
T
R
  • Question
Autres soucis couleur remplissage planning
2
Réponses
17
Affichages
879
chris
chris
V
  • Résolu(e)
XL 2019 Planning de réservation camping automatique
Réponses
5
Affichages
607
ValDorier
V
D
  • Question
XL 2021 création de planning perpétuel annualisé
Réponses
1
Affichages
347
vgendron
vgendron
C
  • Résolu(e)
XL 2021 Peut-on appliquer la mise en forme d'une MFC à plusieurs cellules ?
Réponses
2
Affichages
366
Constantin
C
A
  • Question
XL 2019 lister des données et les répertorier dans un nouveau tableur
Réponses
7
Affichages
425
adgm1
A
Adexa
  • Question
XL 2019 Rechercher un libellé approximatif dans un tableau et afficher une valeur
2
Réponses
29
Affichages
849
Dudu2
Dudu2
C
  • Question
XL 2021 planning personnel cuisine
Réponses
5
Affichages
493
cedric34
C
A
  • Question
Microsoft 365 Planning automatique
Réponses
0
Affichages
483
Aboly
A
Didier Quilghini
  • Résolu(e)
XL 2019 Définir un nom d'un champ lors d'une macro
2
Réponses
28
Affichages
1 K
vgendron
vgendron

Membres actuellement en ligne

2 membres et 28 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
315 127
Messages
2 116 534
Membres
112 771
dernier inscrit
mikadu49