XL 2021 Calendrier Checkbox; ComboBox

Mate59 · 13 Novembre 2023

Bonjour,

Je vous joint le fichier qui me pose problème.
Il s'avère que j'ai passé plusieurs heures à essayer sans vraiment trouver la solution.
J'ai détaillé l'ensemble de ce que je souhaite dans le fichier.

Je vous remercie grandement pour votre aide!

ChTi160 · 15 Novembre 2023

Re
J'ai modifié le code !
Jean marie

Mate59 · 16 Novembre 2023

ChTi160 à dit:

Bonsoir Mate59
Une première approche (perfectible) qui ne répond pas à tout !
Tu testes et tu me dis.

VB:

Private Sub OK_Click()
Application.ScreenUpdating = False
Dim l As Integer, Col As Integer, ColCible As Byte
     With Worksheets("Feuil1")
                For Col = 4 To 16
                             If Me.CBx1.Value = .Cells(4, Col) Then ColCible = Col: Exit For
                 Next Col
For l = 12 To 743
      If Weekday(CDate(.Cells(l, 2)), vbMonday) < 6 Then
            If CDate(Me.CBx3.Value) = CDate(.Cells(l, 2)) And Me.CBx4.Value = .Cells(l, 3) Then
                                     .Cells(l, ColCible) = "CP"
          
                  ElseIf CDate(.Cells(l, 2)) > CDate(Me.CBx3.Value) And CDate(.Cells(l, 2)) < Me.CBx6.Value Then
                                     .Cells(l, ColCible) = "CP"
          
                  ElseIf CDate(Me.CBx6.Value) = CDate(.Cells(l, 2)) And Me.CBx7.Value = .Cells(l, 3) Then
                                     .Cells(l, ColCible) = "CP"
                          
                            If CDate(Me.CBx6.Value) = CDate(.Cells(l, 2)) Then Exit For
            End If
      End If
Next l
End With
Unload Me
End Sub

Bonne fin de Soirée.
Jean marie

En effet, les week-end fonctionnent, les cases ne sont pas remplies.
Pour les jours fériés, ça ne fonctionnent pas et par exemple PERS01 prend son congés au 2/01 Matin jusqu'au 5/01 Après-midi et il y a 2 cases qui ne se remplissent pas, le 02/01 après-midi et le 05/01 Matin.

Il reste donc à résoudre les jours fériés et l'après-midi du jour 1 puis le matin du dernier jour

patricktoulon · 16 Novembre 2023

bonjour
juste en passant
les dates en colonnes B sont des dates par formule
le format est en texte date demie longue
il n'y a rien de pire comme comme concept pour un find ou match ou tout autre fonction de recherche
d'ailleurs ça se voit au code déployé pour colorer une zone en fonction d'un employé et de 2 dates
je suis etonné que @ChTi160 t'ai laissé continuer avec ce concept
ca tiendra pas longtemps ce truc
alors qu'avec un calendrier en 10 lignes c'etait bouclé

patricktoulon · 16 Novembre 2023

d'ailleurs pour info chez moi j'ai essayé toute les méthode match find recherche
et impossible d'avoir un résultat propre sans faire une usine a gaz pour cherche 2 date sur - de 740 ligne dans une colonne
c'est tout simplement Absurde

ChTi160 · 16 Novembre 2023

Bonjour le Fil
Bonjour Patrick
Tout comme il n'est pas conseillé d'utiliser des cellules fusionnées etc etc ..
Pas d'ordi , je regarde plus tard !
Bonne journée
Jean marie

patricktoulon · 16 Novembre 2023

re
tiens @ChTi160
dans le bouton OK tu a à la fin la plage correspondante et la plage des date en colonne B pour comparer les fériés et weekends
te reste plus qu'a mettre les "CP"
le code complet du userform

VB:

Option Explicit
Dim TabloG

Private Sub UserForm_Activate()
Dim I&
TabloG = Application.Transpose(Range("B12:B743").Value)
For I = 1 To UBound(TabloG): TabloG(I) = CStr(Format(TabloG(I), "ddd dd mmmm")): Next
For I = 1 To UBound(TabloG) Step 2: CB2.AddItem TabloG(I): Next
CB3.List = CB2.List
CB1.List = Application.Transpose(Range("D4", Cells(4, 100).End(xlToLeft)).Value)
End Sub

'les CheckBox matin sont automatique au changement des combo
Private Sub CB2_Change(): C1 = CB2.ListIndex > -1: End Sub
Private Sub CB3_Change(): C3 = CB3.ListIndex > -1: End Sub



Private Sub OK_Click()
Dim Lig_1&, Lig_2&, Col&, RnG, RngDate, Sortir As Boolean

'eventuelles condition de sortie
Sortir = CB1.ListIndex = -1 Or CB2.ListIndex = -1 Or CB3.ListIndex = -1
If (C1 = False And C2 = False) Then Sortir = True
If (C3 = False And C4 = False) Then Sortir = True

If Sortir Then MsgBox "Nan!!Nan!!": Exit Sub

'on détermine la ligne 1 en fonction de la date en Cb2 et des CheckBoxs  c1 et c2
Lig_1 = Application.IfError(Application.Match(CB2.Value, TabloG, 0), 0)
If Not C1 Then Lig_1 = Lig_1 + 1
Lig_1 = Lig_1 + 11

'on détermine la derniere ligne en fonction de la date en Cb3 et des CheckBoxs  c3 et c4
Lig_2 = Application.IfError(Application.Match(CB3.Value, TabloG, 0), 0)
If Not C3 Then Lig_2 = Lig_2 + 1
Lig_2 = Lig_2 + 11

Col = CB1.ListIndex + 4

Set RnG = Range(Cells(Lig_1, Col), Cells(Lig_2, Col))
Set RngDate = Range(Cells(Lig_1, "b"), Cells(Lig_2, "b"))

MsgBox "plage employé: " & RnG.Address & vbCrLf & "plage des dates: " & RngDate.Address




End Sub

Mate59 · 17 Novembre 2023

Bonjour à tous,

J'ai réussi avec ce code à faire ce que je voulais.

Je sais que certaines choses ne sont pas conseillé mais j'ai tout de même insisté.

MERCI A TOUS POUR VOTRE AIDE!

VB:

Option Explicit
Dim TabMois(1 To 12, 1 To 3) 'on définit les dimmensions du tableau des Mois 12 (colonne 0 du Combobox Mois et deux Colonnes 1 et 2 du combobox pour les dates limites du Mois
Dim oMonth As Byte, x As Byte
Dim FirstDayMonth As Long
Dim LastDayMonth As Long
Dim Jour As Long
Option Compare Text

Private Sub Label7_Click()

End Sub

Private Sub UserForm_initialize()

x = 0
For oMonth = 1 To 12 'Pour chaque mois
       x = x + 1 'on incremente la Ligne a venir du tableau des Mois
   FirstDayMonth = DateSerial(Range("v2"), oMonth, 1) 'Premier Jour du Mois
    LastDayMonth = DateSerial(Range("v2"), oMonth + 1, 0)  'Dernier jour du mois
        TabMois(x, 1) = Application.Proper(Format(FirstDayMonth, "mmmm")) ''on colle le mois du Jours formaté
        TabMois(x, 2) = FirstDayMonth 'on colle le Jours
        TabMois(x, 3) = LastDayMonth 'on colle le Jours
   
Next
With Me
  With .CBx2
         .List = TabMois 'on colle la Liste(Tableau)
  End With
  With .CBx5
          .List = TabMois 'on colle la Liste(Tableau)
  End With
End With
   
End Sub
Private Sub ANNULER_Click()
Unload Me
End Sub
Private Sub CBx2_Change()
With Me
 With .CBx2 'avec le Combobox
    FirstDayMonth = .List(.ListIndex, 1) 'je récupére la Date de début du mois
    LastDayMonth = .List(.ListIndex, 2) 'je récupére la Date de fin du mois
 End With
 With .CBx3 'avec le Combobox
        .Clear 'je le vide
   For Jour = FirstDayMonth To LastDayMonth 'Pour chaque jour du Mois
        .AddItem Application.Proper(Format(Jour, "dd/mm/yy")) 'Je colle le Jour Foramté dans le Combobox des Jours
   Next Jour
 End With
End With
End Sub

Private Sub CBx5_Change()
With Me
 With .CBx5
    FirstDayMonth = .List(.ListIndex, 1)
    LastDayMonth = .List(.ListIndex, 2)
 End With
 With .CBx6
        For Jour = FirstDayMonth To LastDayMonth
        .AddItem Application.Proper(Format(Jour, "dd/mm/yy"))
   Next Jour
 End With
End With
End Sub
Private Sub OK_Click()

Application.ScreenUpdating = False
Dim l As Integer, c As Integer, colcible As Byte

     With ActiveSheet
'_____________________________________MessageBox_Cases_Non_Remplies________________________________________________
'Si la personne n'est pas renseigner alors msgbox pour la renseigner
If CBx1.Value = "" Then
MsgBox ("Veuillez remplir PERSONNE")
Exit Sub
End If

'Si date de début pas renseigner msg box pour dire de les renseigner
If CBx3.Value = "" Or CBx4.Value = "" Then
MsgBox ("Veuillez remplir DATE DE DEBUT!")
Exit Sub
End If

'Si date de fin pas renseigner msg box pour dire de les renseigner
If CBx6.Value = "" Or CBx7.Value = "" Then
MsgBox ("Veuillez remplir DATE DE FIN!")
Exit Sub
End If

'__________________________________________Procédure_Remplissage_Cellules_____________________________________________
            For c = 4 To 28
                'Si personne alors on sauvegarde la colonne
                If Me.CBx1.Value = .Cells(4, c) Then colcible = c: Exit For
            Next c
           
For l = 12 To 743

'SI jour hors weekend ALORS
If Weekday(CDate(.Cells(l, 2)), vbMonday) < 6 Then

'Lors de la pose d'une demi journée, la case affiche Demi selon si les CBx date de fin sont égales à date de début
            If CDate(CBx3.Value) = CDate(CBx6.Value) And CBx4.Value = CBx7.Value And CDate(CBx3.Value) = CDate(Cells(l, 2)) And CBx4.Value = Cells(l, 3) Then
            Cells(l, colcible) = "Demi CP"
            Else
'SI CBx3 égal date et CBx4 égal am ou pm ALORS on vise la cellule pour la remplir avec "Début"
                    If CDate(CBx3.Value) = CDate(Cells(l, 2)) And CBx4.Value = Cells(l, 3) Then
                    Cells(l, colcible) = "Début CP"
                                'SI jour de semaine +1 case ET Cbx3 = (date le la cellule avant) ET CBx4  = (demi de la cellule après) (règle le problème WE et case après Début vide)
                                If Weekday(CDate(.Cells(l + 1, 2)), vbMonday) < 6 And CBx4.Value = Cells(l, 3) And CDate(CBx3.Value) = CDate(Cells(l, 2)) Then
                                Cells(l + 1, colcible) = "CP"
                                End If
'ET SI date de la colonne est > à la date de CBx3 ET date < à la date de CBx6 ALORS cases correspondantes = CP
                    ElseIf CDate(.Cells(l, 2)) > CDate(Me.CBx3.Value) And CDate(.Cells(l, 2)) < Me.CBx6.Value Then
                    .Cells(l, colcible) = "CP"
                   
'SI CBx6 égale date et CBx7 égale am ou pm ALORS on vise la cellule pour la remplir avec "Fin"
                    ElseIf CDate(CBx6.Value) = CDate(Cells(l, 2)) And CBx7.Value = Cells(l, 3) Then
                    Cells(l, colcible) = "Fin CP"
                                'SI jour de semaine -1 ET Cbx6 = (date le la cellule avant) ET CBx7  = (demi de la cellule après) (règle le problème WE et case avant fin vide)
                                If Weekday(CDate(.Cells(l - 1, 2)), vbMonday) < 6 And CBx7.Value = Cells(l, 3) And CDate(CBx6.Value) = CDate(Cells(l, 2)) Then
                                Cells(l - 1, colcible) = "CP"
                                End If
                      End If
            End If
'__________________________________________On_Vide_Les_Cellules_Jours_Fériés_________________________________________
    If CDate(Cells(l, 2)) = CDate(Range("t3")) Then
    Cells(l, colcible).ClearContents
    End If
        If CDate(Cells(l, 2)) = CDate(Range("t4")) Then
        Cells(l, colcible).ClearContents
        End If
            If CDate(Cells(l, 2)) = CDate(Range("t5")) Then
            Cells(l, colcible).ClearContents
            End If
                If CDate(Cells(l, 2)) = CDate(Range("t6")) Then
                Cells(l, colcible).ClearContents
                End If
                    If CDate(Cells(l, 2)) = CDate(Range("t7")) Then
                    Cells(l, colcible).ClearContents
                    End If
                        If CDate(Cells(l, 2)) = CDate(Range("t8")) Then
                        Cells(l, colcible).ClearContents
                        End If
                            If CDate(Cells(l, 2)) = CDate(Range("t10")) Then
                            Cells(l, colcible).ClearContents
                            End If
                                If CDate(Cells(l, 2)) = CDate(Range("t11")) Then
                                Cells(l, colcible).ClearContents
                                End If
                                    If CDate(Cells(l, 2)) = CDate(Range("t12")) Then
                                    Cells(l, colcible).ClearContents
                                    End If
                                    If CDate(Cells(l, 2)) = CDate(Range("t13")) Then
                                        Cells(l, colcible).ClearContents
                                        End If
                                            If CDate(Cells(l, 2)) = CDate(Range("t14")) Then
                                            Cells(l, colcible).ClearContents
                                            End If
                                                If CDate(Cells(l, 2)) = CDate(Range("t15")) Then
                                                Cells(l, colcible).ClearContents
                                                End If
End If

           

Next l
End With

Unload Me

End Sub

ChTi160 · 17 Novembre 2023

Bonjour le Fil
mate59
je viens de tester ton fichier et rien ne se passe Lol
jean marie

patricktoulon · 17 Novembre 2023

on peut avoir un fichier là
par ce que d'après ce que je vois ca ne correspond plus à la demande de départ
jean-marie a tu testé mon userform

ChTi160 · 17 Novembre 2023

Re
@patrick !
Oui je l'ai testé et j'ai constaté qu'il manque parfois des "CP" surtout en Fin de période !
Moi, je continue à chercher lol
J'utilise des OptionButton puis un Combobox ("Matin" "Après-Midi")
Bonne fin de Journée
Jean marie

Mate59 · 17 Novembre 2023

ChTi160 à dit:
Bonjour le Fil
mate59
je viens de tester ton fichier et rien ne se passe Lol
jean marie

Chez moi tout fonctionne

patricktoulon · 17 Novembre 2023

ChTi160 à dit:
Re
@patrick !
Oui je l'ai testé et j'ai constaté qu'il manque parfois des "CP" surtout en Fin de période !
Moi, je continue à chercher lol
J'utilise des OptionButton .
Bonne fin de Journée
Jean marie

heu ben non tu n'a pas testé puisque je ne l'ai pas fait
je vous ai fait juste la détermination de la plage correspondante
et cela sans utiliser de calcul date mais simplement les index de combo +1 selon les checkbox
resultat un code solide et net

ChTi160 · 17 Novembre 2023

Re
J'avais compris et rajouté les Debut de CP et "Fin de CP" et Les "CP" intermédiaires ???????(donc il a du testé)
Surement une mauvaise interprétation de ma part !
Jean marie

Mate59 · 17 Novembre 2023

Regarde, il fonctionne à moins que tu me dises où il y a un problème

ChTi160 · 17 Novembre 2023

Re
Mate59
Non , j'ai cru que tu avais mis un fichier (mais j'étais sur le Post de Patrick) ou il est normal qu'il ne se passe rien !

Patrick a dit :heu ben non tu n'a pas testé puisque je ne l'ai pas fait

Excuses!
Jean marie

XL 2021 Calendrier Checkbox; ComboBox

XLDnaute Junior

Pièces jointes

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Partager cette page

Statistiques des forums