Réservation V2 sans monthview

Le 20/06/2015 à 11:44

Bonjour,

Je suis en cours de finalisation de mon projet de fichier planning sans module monthview.

Il me reste un souci de gestion date. J'ai imaginé pouvoir répéter une réservation plusieurs fois, soit toutes les semaines paires ou impaires soit tous les mois.

Dans le cas des semaines j'ai un souci de "bornage" de fin de boucle. Par exemple, lorsque je souhaites faire une réservation toutes les semaines jusqu'à la fin septembre et que le jour de réservation est un vendredi la réservation commence du vendredi 19 juin et se termine le vendredi 2 octobre Je pense qu'il faudrait faire un test de calcul de fin pour déterminer. Selon le nombre de semaine dans la boucle la date finale va au delà du mois ou pas, si tel est le cas alors il faut soustraire 1 à la boucle.

Dans les cas d'une répétion tout les mois, Eriiic m'a proposé une fonction perso qui détermine le énième du jour de la date. Ce qui permettrai de boucler sur les jours plutôt que sur le numéro de la date. Exemple, une réservation le samedi 20 juin sur trois. Première date le samedi 20 juin, la deuxième date le lundi 20 juin et la troisième date le jeudi 20 aout L'idée serait de faire le samedi 20 juin qui est le troisième samedi du mois et que les dates seraient 18/07/2015 et le 15/08/2015 qui sont bien les troisièmes samedis de chaque mois...

Le code de Eriiic

'AUTEUR: Eriiic via le forum excel-pratique
'DATE: 20/06/2015
'Titre: Réservations V2

Option Explicit

Sub test()
    Debug.Print moisSuivantMmJS(#3/4/2015#) ' #m/d/yyyy#
End Sub

Function moisSuivantMmJS(dat As Date, Optional NbMois As Long = 1) As Variant
    ' à partir d'une date,
    ' fournit le même xième 'jour de la semaine' du mois suivant
    ' ex : moisSuivant("10/03/15")   ==> 14/04/2015 (2e mardi du mois suivant)
    ' ex : moisSuivant("10/03/15",3) ==> 09/06/2015 (2e mardi 3 mois plus tard)
    ' *** limité au 4ème jour/sem du mois ***
    ' eriiic

    Dim numJo As Long, d1 As Date
    numJo = Day(dat) \ 7
    If numJo > 3 Then
        'limitation au 4ème dans le mois
        moisSuivantMmJS = CVErr(xlErrNum) ' #NOMBRE!, hors domaine
        Exit Function
    End If
    d1 = CDate("1/" & Format(DateAdd("m", NbMois, dat), "mm/yyyy")) ' 1er du mois
    moisSuivantMmJS = d1 + (Weekday(dat, 2) - Weekday(d1, 2) + 7) Mod 7 + numJo * 7
End Function

Je vous confis que je suis au seuil de mes compétences et que je nage

Le code de réservation établit avec Banzaï en 2013

Private Sub CommandButton_enreg_Click()
Dim i As Integer, NbMois As Integer, NbJour As Integer, FinBoucle As Integer
Dim Ligne_Insertion As Long
Dim ModeCalcul As Integer
Dim Semaine As Byte, Pas As Byte
Dim ladate As Date, Hdeb As Date, HFin As Date
Dim Cel As Range, Depart As String

ladate = CDate(Me.Label_date.Caption)

'Mettre une condition de remplissage tout les champs doivent être renseignés sauf les boutons options

  If Me.ComboBox_debut.ListIndex = -1 Then
    MsgBox "Veuillez indiquer l'heure de début de votre réservation, merci.", 64, ""
  ElseIf Me.ComboBox_fin.ListIndex = -1 Then
    MsgBox "Veuillez indiquer l'heure de fin de votre réservation, merci.", 64, ""
  ElseIf Me.ComboBox_pro.ListIndex = -1 Then
    MsgBox "Veuillez indiquer votre nom, merci.", 64, ""
  ElseIf Me.ComboBox_type.ListIndex = -1 Then
    MsgBox "Veuillez indiquer le type de votre réservation, merci.", 64, ""
  ElseIf Me.ComboBox_meeting.Value = "" Then
    MsgBox "Veuillez indiquer le nom de votre réservation, merci.", 64, ""
  ElseIf Me.OpB_allweeks = True And ComboBox_month.ListIndex = -1 Then
        MsgBox "Veuillez indiquer le mois de fin de la réservation, merci.", 64, ""
  Else                                                    'Si OK

    With Sheets("BD_CAL")
      Pas = 1   ' Par défaut
      If Modif = True Then
        Ligne_Insertion = Me.LabelLigne.Caption
        Me.OpBUnefois = True        ' On ne modifie qu'un rendez-vous
      Else
        Ligne_Insertion = .Range("A" & Rows.Count).End(xlUp).Row + 1

        If Me.OpB_allmonth = True Then
          FinBoucle = ComboBox_month.ListIndex
          NbMois = 1
        ElseIf Me.OpB_allweeks = True Then
          FinBoucle = Application.WorksheetFunction.WeekNum(DateSerial(year(ladate), Month(ladate) + ComboBox_month.ListIndex + 1, 0)) - Application.WorksheetFunction.WeekNum(ladate)
          NbJour = 7

          Semaine = NOSEM(CDate(ladate))
          If Me.CheckBox_pair = True Then                                     ' Que les semaines paires
            If Semaine Mod 2 <> 0 Then                                        ' Si la semaine n'est pas paire
              Label_date.Caption = DateAdd("d", 7, CDate(Label_date.Caption)) ' On prend la semaine suivante
              ladate = Me.Label_date                                          ' On rectifie le calendrier
            End If
            Pas = 2
          ElseIf Me.CheckBox_impaire = True Then                              ' Que les semaines impaires
            If Semaine Mod 2 <> 1 Then                                        ' Si la semaine n'est pas impaire
              Label_date.Caption = DateAdd("d", 7, CDate(Label_date.Caption)) ' On prend la semaine suivante
              ladate = Me.Label_date                                          ' On rectifie le calendrier
            End If
            Pas = 2
          End If
        End If
      End If

      ' Boucle qui vérifie si une date n'est pas réservée
      Hdeb = CDate(Me.ComboBox_debut)
        HFin = CDate(Me.ComboBox_fin)
        For i = 0 To FinBoucle Step Pas
          ladate = DateAdd("m", (i * NbMois), CDate(Label_date.Caption) + (i * NbJour))
          Set Cel = .Columns("A").Find(what:=ladate, LookIn:=xlValues, Lookat:=xlWhole)
          If Not Cel Is Nothing Then
            Depart = Cel.Address
            Do
              If Cel.Offset(0, 8) = NomSalle Then
                If HFin > CDate(Cel.Offset(0, 1)) And Hdeb < CDate(Cel.Offset(0, 2)) Then
                  ' Pas en mode modification ou la ligne testée n'est pas celle qui doit être modifiée
                  If Modif = False Or Cel.Row <> Ligne_Insertion Then
                    MsgBox "Réservation impossible :" & Chr(10) & "Créneau déjà occupé le " & ladate & " à " & Format(Hdeb, "h\Hmm"), 16, "A.Li.A"
                    Exit Sub
                  End If
                End If
              End If
             Set Cel = .Columns("A").FindNext(Cel)
            Loop While Depart <> Cel.Address
          End If
        Next i

      With Application
        ModeCalcul = .Calculation
        .Calculation = xlCalculationManual
      End With

      ' Boucle d'inscription des RDV
   For i = 0 To FinBoucle Step Pas
        .Cells(Ligne_Insertion, 1) = DateAdd("m", (i * NbMois), CDate(Label_date.Caption) + (i * NbJour))
        .Cells(Ligne_Insertion, 2) = ComboBox_debut.Value
        .Cells(Ligne_Insertion, 3) = ComboBox_fin.Value
        .Cells(Ligne_Insertion, 4) = ComboBox_pro.Value
        .Cells(Ligne_Insertion, 5) = ComboBox_type.Value
        .Cells(Ligne_Insertion, 6) = ComboBox_meeting.Value
        .Cells(Ligne_Insertion, 7).Formula = "=IF(A" & Ligne_Insertion & "="""","""",I" & Ligne_Insertion & "&A" & Ligne_Insertion & "&""|""&COUNTIFS($A$2:A" & Ligne_Insertion & ",A" & Ligne_Insertion & ",$I$2:I" & Ligne_Insertion & ",I" & Ligne_Insertion & "))"
        .Cells(Ligne_Insertion, 8).Formula = "=I" & Ligne_Insertion & "&A" & Ligne_Insertion & " &ROUND(B" & Ligne_Insertion & ",4)"
        .Cells(Ligne_Insertion, 9) = NomSalle

        Ligne_Insertion = Ligne_Insertion + 1
      Next i

      ' le tri suivant la date et heure début
      Ligne_Insertion = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A2:J" & Ligne_Insertion).Sort key1:=.Range("A2"), order1:=xlAscending, dataoption1:=xlSortNormal, _
                                            key2:=.Range("B2"), order2:=xlAscending, dataoption2:=xlSortNormal, Header:=xlNo

    End With

    Application.Calculation = ModeCalcul

    If Me.OpB_allmonth = True Or Me.OpB_allweeks = True Then
        MsgBox "Réservation " & NomSalle & " :" & Chr(10) & Chr(10) & "de " & Format(ComboBox_debut, "HH:mm") & " à " & Format(ComboBox_fin, "HH:mm") & Chr(10) & "du " & Format(Label_date, "Dddd dd mmmm yyyy") & Chr(10) & "au " & Format(ladate, "Dddd dd mmmm yyyy"), 64, ""
     Else: MsgBox "Réservation " & NomSalle & " :" & Chr(10) & Chr(10) & "de " & Format(ComboBox_debut, "HH:mm") & " à " & Format(ComboBox_fin, "HH:mm") & Chr(10) & "le " & Format(ladate, "Dddd dd mmmm yyyy"), 64, ""
    End If

    Unload Me

  End If
End Sub

Voilà pour ma demande,

Merci d'avance aux VBAistes.

Leakim

Le 20/06/2015 à 12:04

Bonjour Leakim,

Je ne dois pas être réveillé

Dans tout ce que tu dis, que souhaites exactement ?

Le 20/06/2015 à 12:21

Bonjour BrunoM45,

Dans tout ce que je dis, j'aimerai pouvoir avoir une piste pour inclure dans le code un test de fin de boucle pour les semaines et faire appel à la fonction de eriiic pour que la boucle des mois.

Je sais que c'est pas facile d'aborder un projet aussi avancé... C'est parfois pas simple de s'imprégner.

Merci de ton intérêt,

Leakim

Le 20/06/2015 à 20:11

Bonjour,

Pas sûr (même certain) de bien comprendre non plus...

Le but de la fonction demandée à l'époque était : en lui fournissant une date au 2ème mardi du mois par exemple, retourner la date de 2ème mardi du mois suivant.

Si tu veux une réservation toutes les semaines ou tous les 15 jours tu fais +7 ou +14 et ça tombera le même jour de semaine.

Pourquoi tu voudrais utiliser cette fonction ? Elle n'est pas du tout adaptée à ça.

Le principe éventuel : quand tu fais ta boucle calcule en premier le 01 du mois suivant (donc 01-10-15 pour ton exemple) et si ta date calculée est >= tu ne l'inscris pas et tu sors de la boucle.

Mais tu ferais mieux de demander le nombre de réservations voulues ou la date de fin et la respecter (libre à l'utilisateur de saisir le 12 ou le 30 du mois) et sortir dès que c'est atteint.

Sinon tu devrais donner un exemple complet et précis pour ton pb.

eric

Le 20/06/2015 à 20:46

Bonjour Eriiic,

Je suis visiblement pas clair

Tu as raison pour les réservations semaines, ta fonction n'est pas faite pour cela. Je vais creuser ta proposition du nombre de semaines.

Pour les mois c'est bien ce que tu dis que je veux faire... mais je suis perdu sur les modif dans le code.

Pour l'exemple tu trouveras sur le fichier que j'ai joins avec c-joint.

Merci pour ton suivi,

Leakim

Le 20/06/2015 à 20:54

Ah oui, je n'ai pas ouvert.

Tu devrais mettre un petit modop sur l'utilisation, quelle procédure est en cause, son emplacement. Et un exemple de saisie avec le résultat mauvais et celui attendu.

Ca évite que les personnes intéressées passent 1/4h-1/2h à essayer de comprendre et de partir sur un mauvais truc.

Mais ça reste ouvert à tout le monde, j'ai d'autres trucs en route.

C'était surtout pour essayer d'éclaircir le sujet comme j'avais qq souvenirs.

eric

Le 21/06/2015 à 00:37

suite...

Je me suis penché un peu dessus.

Si j'ai bien compris (pas sûr) avec :

        ElseIf Me.OpB_allweeks = True Then
          FinBoucle = Application.WorksheetFunction.WeekNum(DateSerial(year(ladate), Month(ladate) + ComboBox_month.ListIndex + 1, 0)) - Application.WorksheetFunction.WeekNum(ladate)
          NbJour = 7

parfois tu te retrouves en octobre alors qu'une fin a été demandée en septembre et tu veux -1 à FinBoucle ?

Si c'est ça, essaie avec cette rustine à mettre après ces 3 lignes. Sans exemple qui va mal je n'ai pas eu le courage de contrôler et modifier ta formule de calcul de boucle.

If Format(DateAdd("m", (FinBoucle * NbMois), CDate(Label_date.Caption) + (FinBoucle * NbJour)), "mmmm") <> LCase(ComboBox_month) Then FinBoucle = FinBoucle - 1

eric

Le 21/06/2015 à 07:27

Bonjour Eriiic et les autres,

Je dois confirmer que je suis vraiment pas vendeur sur mon projet J'arrive à la fin et c'est terriblement frustrant de ne pas savoir finaliser seul.

En même temps en faisant comme çà, j'ai reçu des propositions auxquelles je n'ai pas pensées

Je voulais te remercier Eriiic pour ta rustine car c'est exactement cela!!! Tu as bien tout compris. J'ai pris le temps de vérifier sur le fichier que je vous ai mis en lien. Pour confirmer, j'ai utilisé une version sans ta rustine et là je retrouve mon bug dès la première réservation.

MERCI !

Je valide résolu sur la moitié de mon problème bug réservation semaine

Reste mon bug avec les réservations mensuelles.

En espérant avoir encore de votre soutien.

Cordialement,

Leakim

Le 21/06/2015 à 09:40

Bonjour,

Parce qu'il y avait 2 questions ?

J'ai beau relire je ne vois pas la 2nde...

eric

Le 21/06/2015 à 10:22

Bonjour,

Décidément, je suis nul pour communiquer

Je vais continuer sur avec un autre post. Car, oui j'ai toujours un bug pour les réservations sur plusieurs mois. J’avais en tête d'utiliser la fonction perso que Eriiic avait proposé, mais je ne parviens pas à l'intégrer à mon code.

Je clôture ce post qui est résolu et je reviens avec mon ultime bug en espérant être clair dans ma demande. J'ai compris qu'il faut que je fasse un tuto.

Merci encore et à bientôt,

Leakim

Rechercher des sujets similaires à "reservation monthview"