Interdir les réservations inférieure à 1 heure
p
Bonjour le forum,
Dans un planning de réservation, je souhaiterais interdir les réservations inférieure à 1 heure.
J'ai essayé diverses formule mais ça ne marche pas.
Pourriez m'expliquer la démarche à suivre ainsi que la formule à employer.
Merci et bonne journée à tous.
j
Bonjour,
il faut qu'on ait ton fichier, ou une adaptation, pour qu'on se câle directement à tes besoins.
Merci
p
Bonjour jeremie25
Option Explicit
Private MaPlage As Range
Private CouleurUser As Integer
Dim Lig As Long, LigDeb As Long, LigFin As Long, Col As Integer, ColDebH As Integer, ColFinH As Long, IndCol As Integer
Private Sub CmBAnnuler_Click()
Unload Me
End Sub
Private Sub CmbValider_Click()
'Tester si tous les combo sont rempli avant d'appeler la fonction
If Me.ComboNomUtilisateur.Value = "" Then
Me.ComboNomUtilisateur.SetFocus
MsgBox "Merci de remplir le nom de l'utilisateur !"
Exit Sub
End If
If Me.ComboDateDébut.Value = "" Then
Me.ComboDateDébut.SetFocus
MsgBox "Merci de remplir la date de début !"
Exit Sub
End If
If Me.ComboDateFin.Value = "" Then
Me.ComboDateFin.SetFocus
MsgBox "Merci de remplir la date de fin !"
Exit Sub
End If
If Me.ComboHeureDébut.Value = "" Then
Me.ComboHeureDébut.SetFocus
MsgBox "Merci de remplir l'heure de debut !"
Exit Sub
End If
If Me.ComboHeureFin.Value = "" Then
Me.ComboHeureFin.SetFocus
MsgBox "Merci de remplir l'heure de fin !"
Exit Sub
End If
' Appeler la fonction
If ValidationReservation(Me.ComboNomUtilisateur, Me.ComboDateDébut, Me.ComboHeureDébut, Me.ComboDateFin, Me.ComboHeureFin) Then
Me.ListBoxVh.Visible = True
Me.LbInfo.Visible = True
Me.LbReservation.Visible = True
Else
MsgBox "Aucune réservation n'est possible dans cette plage horaire"
Me.ListBoxVh.Visible = False
Me.LbInfo.Visible = False
Me.LbReservation.Visible = False
Exit Sub
End If
End Sub
Public Function ValidationReservation(Nom As String, MaDateDeb As Date, HeureDebut As Date, MaDateFin As Date, HeureFin As Date) As Boolean
Dim MaFeuille As Worksheet, TabF As String
Dim IsLibre As Boolean
' Remplissage du tableau des feuilles à ne pas prendre en compte
TabF = "Jours ouvrés;Menu;Data;Params;Cadre;Impression"
'
' Calcul de la ligne de date de DEBUT
LigDeb = 3 + DatePart("y", MaDateDeb)
LigFin = 3 + DatePart("y", MaDateFin)
'
' Calcul la colonne d'heure DEBUT
ColDebH = Me.ComboHeureDébut.ListIndex + 2
'
' Calcul la colonne d'heure FIN
ColFinH = Me.ComboHeureFin.ListIndex + 1
'
' Vider la listbox de choix
Me.ListBoxVh.Clear
' Pour chaque feuille du classeur
For Each MaFeuille In Worksheets
IsLibre = True ' Mettre la variable à VRAI ici
' Si c'est une feuille de planning
If InStr(1, TabF, MaFeuille.Name, vbTextCompare) = 0 Then
' Pour chaque ligne de réservation
For Lig = LigDeb To LigFin
' Pour chaque colonne
For Col = ColDebH To ColFinH
' Si la cellule n'est pas vide
If MaFeuille.Cells(Lig, Col).Value <> "" Or MaFeuille.Cells(Lig, Col).MergeCells Then
IsLibre = False
Exit For
End If
Next Col
Next Lig
' La réservation est-elle possible
If IsLibre Then Me.ListBoxVh.AddItem (MaFeuille.Name)
End If
Next MaFeuille
ValidationReservation = (Me.ListBoxVh.ListCount > 0)
End Function
Private Sub ComboDateDébut_Change()
Me.ComboDateFin.Text = Me.ComboDateDébut.Text
End Sub
Private Sub ComboHeureDébut_Change()
If Me.ComboHeureFin.Value = "" Then
Me.ComboHeureFin.Text = Me.ComboHeureDébut.Text
End If
If TimeValue(Me.ComboHeureFin) < TimeValue(Me.ComboHeureDébut) Then
MsgBox "L'heure de fin ne peut pas être inférieure à l'heure de début", vbCritical, "ATTENTION ..."
Me.ComboHeureFin.Text = Me.ComboHeureDébut.Text
End If
End Sub
Private Sub ComboNomUtilisateur_AfterUpdate()
Dim NbVal As Integer, Rep
' Si le combobox est vide
If Me.ComboNomUtilisateur.Value = "" Then Exit Sub
' Max d'utilisateurs = 55
NbVal = Application.Evaluate("COUNTA(Params!A:A)")
If NbVal = 55 Then
MsgBox "Le nombre d'utilisateurs maximum est déjà atteint !"
Me.ComboNomUtilisateur.Value = ""
End If
' Si le nom a été saisi et n'existe pas dans la liste
If Me.ComboNomUtilisateur.ListIndex = -1 Then
Rep = MsgBox("Cet utilisateur n'existe pas dans la liste, voulez-vous le créer ?", vbQuestion + vbYesNo, "QUESTION ....")
If Rep = vbYes Then
' Seul l'administrateur à le droit => demander le mot de passe
UsFAdmin.Show
If ModeAdm = False Then Me.ComboNomUtilisateur.Value = "": Exit Sub
' Ajoute l'utilisateur à la liste
Sheets("Params").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Me.ComboNomUtilisateur
' Ajoute l'utilisateur au combobox
Me.ComboNomUtilisateur.AddItem Me.ComboNomUtilisateur
End If
End If
End Sub
Private Sub ListBoxVh_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim TabF As String
Dim RUser As Range
' Remplissage du tableau des feuilles à ne pa sprendre en compte
TabF = "Jours ouvrés;Menu;Data;Params;Cadre;Impression"
'
' Calcul de la ligne de date de DEBUT
LigDeb = 3 + DateValue(Me.ComboDateDébut) - DateValue(Sheets("Jours ouvrés").Range("B4")) + 1
LigFin = 3 + DateValue(Me.ComboDateFin) - DateValue(Sheets("Jours ouvrés").Range("B4")) + 1
'
' Calcul la colonne d'heure DEBUT
IndCol = Abs(Minute(Me.ComboHeureDébut) = 30) ' Augmente d'une colonne si heure de début contient 1/2 heure
ColDebH = ((Int(TimeValue(Me.ComboHeureDébut) * 24) - 7 + 1) * 2) + IndCol
'
' Calcul la colonne d'heure FIN
IndCol = IIf(Minute(Me.ComboHeureFin) = 30, 0, -1) ' Diminue d'une colonne si heure de début contient 1/2 heure
ColFinH = ((Int(TimeValue(Me.ComboHeureFin) * 24) - 7 + 1) * 2) + IndCol
If ListBoxVh.Value <> "" Then
If LigDeb = LigFin Then
Set MaPlage = Range(Cells(LigDeb, ColDebH), Cells(LigDeb, ColFinH))
Else
' Traitement d'un écart de plusieurs dates
For Lig = LigDeb To LigFin
If Lig = LigDeb Then
Set MaPlage = Range(Cells(LigDeb, ColDebH), Cells(LigDeb, 25))
End If
If Lig > LigDeb And Lig < LigFin Then
Set MaPlage = Union(MaPlage, Range(Cells(Lig, 2), Cells(Lig, 25)))
End If
If Lig = LigFin Then
Set MaPlage = Union(MaPlage, Range(Cells(LigFin, 2), Cells(LigFin, ColFinH)))
End If
Next Lig
End If
' Récupérer la couleur du nom
Set RUser = Sheets("Params").Columns("A:A").Find(What:=ComboNomUtilisateur, After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
CouleurUser = RUser.Interior.ColorIndex
Set RUser = Nothing ' Effacer la variable objet
If InsertionData Then
If MiseEnFormeReservation(ListBoxVh.Value) Then
MsgBox "La réservation est enregistrée"
Else
MsgBox "Une erreur est survenue durant la mise en forme du calendrier" & vbCr & vbCr & "La réservation est enregistrée mais pas affiché dans le calendrier", vbCritical
End If
Else
MsgBox "Une erreur est survenue durant l'enregistrement" & vbCr & vbCr & "La réservation n'est pas enregistrée", vbCritical
End If
End If
End Sub
Private Function InsertionData() As Boolean
Dim resultat As Boolean
Dim LigneFin As Integer
On Error GoTo fin
With Sheets("Data")
LigneFin = .Range("A" & Rows.Count).End(xlUp).Row + 1
'Numéro de transaction
If LigneFin = 2 Then
.Cells(LigneFin, 1) = 1
Else
.Cells(LigneFin, 1) = .Cells(LigneFin - 1, 1).Value + 1
End If
'Nom utilisateur
.Cells(LigneFin, 2) = Me.ComboNomUtilisateur
'Objet
.Cells(LigneFin, 3) = Me.ListBoxVh.Value
'Date début
.Cells(LigneFin, 4) = DateValue(Me.ComboDateDébut.Value)
'Heure debut
.Cells(LigneFin, 5) = Me.ComboHeureDébut.Value
'Date fin
.Cells(LigneFin, 6) = DateValue(Me.ComboDateFin.Value)
'Heure fin
.Cells(LigneFin, 7) = Me.ComboHeureFin.Value
'Plage
.Cells(LigneFin, 8) = MaPlage.Address
'Commentaire
.Cells(LigneFin, 9) = Me.Commentaire.Value
End With
resultat = True
fin:
InsertionData = resultat
End Function
Private Function MiseEnFormeReservation(NomFeuille As String) As Boolean
Dim resultat As Boolean, FirstCel As String
'On Error GoTo fin
' Déprotéger la feuille
Call Protection(NomFeuille, False)
' Faire la mise en forme
With Sheets(NomFeuille)
' Inscrire le nom dans la première cellule
FirstCel = Left(MaPlage.Address, InStr(1, MaPlage.Address, ":") - 1)
.Range(FirstCel).Value = Me.ComboNomUtilisateur
With .Range(MaPlage.Address)
.Merge
.Interior.ColorIndex = CouleurUser
'.HorizontalAlignment = xlCenter
.HorizontalAlignment = xlCenterAcrossSelection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
'Ajout des commentaires
If Commentaire <> "" Then Sheets(NomFeuille).Range(FirstCel).AddComment Text:=Commentaire.Text
End With
End With
resultat = True
fin:
MiseEnFormeReservation = resultat
' Protéger la feuille
Call Protection(NomFeuille, True)
End Function
Private Sub UserForm_Initialize()
Dim Cell As Range
With Sheets("Params")
'affiche la liste des utilisateurs
For Each Cell In .Range("A2:A" & .Range("A65536").End(xlUp).Row)
ComboNomUtilisateur.AddItem (Cell)
Next
End With
With Sheets("Params")
' Inscrit les valeurs dans les listes déroulantes des dates
For Each Cell In .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
' N'afficher dans la liste que les jours ouvrés : du lundi au samedi
If Weekday(Cell, vbMonday) < 6 Then
Me.ComboDateDébut.AddItem (Cell)
Me.ComboDateFin.AddItem (Cell)
End If
Next
End With
With Sheets("Params")
' Inscrit les valeurs dans les listes déroulantes des heures
For Each Cell In .Range("C2:C" & .Range("C65536").End(xlUp).Row)
Me.ComboHeureDébut.AddItem Format((Cell), "hh:mm")
Me.ComboHeureFin.AddItem Format((Cell), "hh:mm")
Next
End With
ComboNomUtilisateur.Value = nom_utilisateur_de_poste
End Sub
Private Sub ClearFiche()
ComboNomUtilisateur.Text = ""
ComboDateDébut.Text = ""
ComboHeureDébut.Text = ""
ComboHeureFin.Text = ""
ListBoxVh.Clear
ListBoxVh.Visible = False
LbInfo.Visible = False
LbReservation.Visible = False
End SubDésolé, sinon je peux l'envoyer par mail
Bonne journée et merci