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

V
  • Résolu(e)
XL 2019 Planning de réservation camping automatique
Réponses
5
Affichages
420
ValDorier
V
R
  • Question
Autres soucis couleur remplissage planning
Réponses
11
Affichages
218
romain2905
R
C
  • Résolu(e)
XL 2021 Peut-on appliquer la mise en forme d'une MFC à plusieurs cellules ?
Réponses
2
Affichages
329
Constantin
C
A
  • Question
XL 2019 lister des données et les répertorier dans un nouveau tableur
Réponses
7
Affichages
368
adgm1
A
A
  • Question
Microsoft 365 Planning automatique
Réponses
0
Affichages
421
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
918
vgendron
vgendron
C
  • Question
XL 2021 planning personnel cuisine
Réponses
5
Affichages
431
cedric34
C
halecs93
  • Résolu(e)
XL 2016 Copie transposée de planning
2
Réponses
24
Affichages
842
job75
job75
C
  • Question
Microsoft 365 comment afficher une images dans INCORPORER("Forms.Image.1";"") avec une Clique de la souris
Réponses
1
Affichages
474
fanch55
fanch55
nadem0068
  • Question
XL 2019 période couplé avec un nom
Réponses
4
Affichages
314
nadem0068
nadem0068

Membres actuellement en ligne

17 membres et 308 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
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh