Format heures : 14 > 15

Bonjour à tous,

J'ai ce souci qui m'empêche de cadrer les heures d'occupation de salles pour éviter les doublons.

Je fais des test avec la 1ere ligne de ma BD:

     For i = 1 To tb2.ListRows.Count '2e et 4e ok
        hor2 = CDate(Me.Hor.Value) + CDate(Me.dur.Value) 'horaire fin UF
        hor2BD = Format(tb2.DataBodyRange(i, 6).Value + tb2.DataBodyRange(i, 5).Value, "hh:mm")
        hor2BD = CDate(hor2BD)
        If CDate(Me.Hor.Value) > Format(CDate(tb2.DataBodyRange(i, 5).Value), "hh:mm") Then 
            cpt = 1
            Exit For
        End If
    Next i
    If cpt = 1 Then msgbox "La salle est déjà occupée ce jour à cette horaire.":  GoTo fin 

Pour résumer, à ce code

If CDate(Me.Hor.Value) > Format(CDate(tb2.DataBodyRange(i, 5).Value), "hh:mm") Then

qui donne 14 > 15, il me répond oui

Voilà le fichier, avec un clic droit pour ouvrir le formulaire.

Merci pour vos réponses.

Bonjour,

Il manque un USF (Orientation) dans votre fichier nous ne pourrons donc pas vous aider

A+

C'est vrai c'était pas le même fichier. Vu l'état du bureau j'arrive pas à envoyer une copie

Depuis un autre répertoire de mon disque externe, çà va.

Merci

Bonjour,

If CDate(Me.Hor.Value) > Format(CDate(tb2.DataBodyRange(i, 5).Value), "hh:mm") Then

CDate() : numérique
Format() : chaine

Compare 2 numériques si tu veux que ça fonctionne , ton Format() est de trop.
eric

Bonjour eriiic,

Pour moi, si j'ai bien tout compris, en plus du soucis numérique+chaine, c'est plus complexe que ça

Un code qui doit convenir, mais à transformer

Function PlageExiste(dateNouveau As Date, heureNouveau As Date, dureeNouveau As Double) As Boolean
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dateExistant As Date
    Dim heureExistant As Date
    Dim dureeExistant As Double
    Dim debutNouveau As Date
    Dim finNouveau As Date
    Dim debutExistant As Date
    Dim finExistant As Date
    ' Définir la feuille de calcul où sont stockés les rendez-vous
    Set ws = ThisWorkbook.Sheets("Planning")
    ' Définir la dernière ligne utilisée dans la colonne Date
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' Calculer l'heure de début et de fin du nouveau rendez-vous
    debutNouveau = dateNouveau + heureNouveau
    finNouveau = debutNouveau + dureeNouveau / 24
    ' Parcourir tous les rendez-vous existants
    For i = 2 To lastRow ' Assumes the first row is header
        dateExistant = ws.Cells(i, 1).Value
        heureExistant = ws.Cells(i, 2).Value
        dureeExistant = ws.Cells(i, 3).Value

        ' Calculer l'heure de début et de fin du rendez-vous existant
        debutExistant = dateExistant + heureExistant
        finExistant = debutExistant + dureeExistant / 24

        ' Vérifier les chevauchements
        If (debutNouveau < finExistant) And (finNouveau > debutExistant) Then
            ChevauchementExiste = True
            Exit Function
        End If
    Next i
    PlageExiste = False
End Function

A+

Re JExcel2fr, bonjour Eriiic,

Ok pour l'erreur de format, mais ce code

        If CDate(Me.Hor.Value) > CDate(tb2.DataBodyRange(i, 5).Value) Then ' And hor2 <= hor2BD) _ '

donne la même réponse d'occupation.

JExcel2fr,

Pour le chevauchement, je me base sur ce schéma.

   If tb2.DataBodyRange(i, 4).Value = CDate(Me.datR.Value) And _
         (Me.Hor.Value < Format(tb2.DataBodyRange(i, 5).Value, "hh:mm") And hor2 > Format(tb2.DataBodyRange(i, 5).Value, "hh:mm")) _
            Or (Me.Hor.Value < hor2BD And hor2 > hor2BD) _
            Or CDate(Me.Hor.Value) > CDate(tb2.DataBodyRange(i, 5).Value)  And hor2 < hor2BD) _  
            Or (Me.Hor.Value < Format(tb2.DataBodyRange(i, 5).Value, "hh:mm") And hor2 > hor2BD)  _
       '     And tb2.DataBodyRange(i, 2).Value = Me.salle.Value Then
            cpt = 1
            Exit For
        End If

Et comme j'ai pas de 2eme horaire mais une durée, j'ai ajouté la durée au 1er horaire pour l'avoir.

Mais là çà passe pas sur le 3éme argument (et le 1er terme surtout) des 4 (hormis celui de la date au début et celui de la salle à la fin).

Mais je vais regardé si je peux exploiter ton code sur la date + horaire.

Merci

Bonjour à tous,

une proposition de fonction qui retourne True si ok, False si chevauchement.

Sub test2()
    msgbox validerH("Salle 2", #4/20/2024#, #1:00:00 PM#, #1:00:00 AM#)
End Sub

Function validerH(salle As String, dat, hDeb, durée) As Boolean
    Dim datas, lig As Long
    Dim t11 As Long, t12 As Long, t21 As Long, t22 As Long '
    Dim pl As Range, ok As Boolean

    datas = [B2].Resize(Cells(Rows.Count, 2).End(xlUp).Row - 1, 5)
    ok = True
    t11 = hDeb * 24 * 60
    t12 = (hDeb + durée) * 24 * 60
    For lig = 1 To UBound(datas)
        If salle = datas(lig, 1) And dat = datas(lig, 3) Then
            t21 = datas(lig, 4) * 24 * 60
            t22 = (datas(lig, 4) + datas(lig, 5)) * 24 * 60
            Set pl = Intersect(Range(t11 & ":" & t12), Range(t21 & ":" & t22))
            If Not pl Is Nothing Then
                If pl.Rows.Count > 1 Then ok = False: Exit For
            End If
        End If
    Next lig
    validerH = ok
    Set pl = Nothing
End Function

eric

Merci Eriic, je garde de côté.

Finalement j'ai trouvé. En mettant un msgbox sur la date une fois la condition réalisée, il m'a affiché le 29/04, donc une autre date.

Le souci était mes parenthéses, il fallait une double parenthése au début des 4 conditions et une à la fin des 4.

Merci

Tu es trop rapide, j'ai fait une petite modif...

Super elle fonctionne bien ta solution.

Merci pour vos réponses. Bsoir

Bonjour à tous,

Me revoilà parce que je galère encore sur ma méthode qui marche plus pour une modification, et j'essaie de prendre la méthode d'Eriic.

Mais çà s'affiche en rouge dés que j'essaie de changer, les chiffres du msgbox par mes variables.

Merci de ton aide ou de quelqu'un à qui cà parle.

Bonjour,

une fonction retourne une valeur.
Il faut donc l'affecter à une variable si tu veux garder trace du résultat, ou la tester directement.
ok = validerH(....)

if not ok then

ou

If not validerH(....) then msgbox "essaie encore"

eric

PS : les # sont pour dire à vba qu'il s'agit d'une valeur date (passée en dur). Ils ne sont pas à mettre quand tu passes une variable date à la fonction

bonjour Eriiic,Trucky93,jExcel2Fr,

avec cette fonction personnalisée

Sub Testing()
     MsgBox "Test 1 : " & Cheveauchement("Salle 2", #4/20/2024#, #1:00:00 PM#, #1:00:00 AM#, range("Reserv"))
     MsgBox "Test 2 : " & Cheveauchement("Salle 1", DateSerial(2024, 1, 1), TimeSerial(16, 0, 0), TimeSerial(0, 15, 0), range("Reserv"))
End Sub

Function Cheveauchement(salle As String, MaDate, hDebut, Duree, Tableau As range) As Boolean
     Dim Arr, Debut As Double, Fin As Double, b As Boolean, i, x

     Arr = Tableau.Value2                    'tableau >>> array
     Debut = MaDate + hDebut                 'début cette reservation
     Fin = Debut + Duree                     'fin cette reservation

     For i = 1 To UBound(Arr)                'boucler réservations actuelles
          If StrComp(Arr(i, 2), salle, 1) = 0 Then     'même salle
               x = Arr(i, 4) + Arr(i, 5)     'début d'une réservation actuelle
               b = (Application.Max(0, Application.Min(x + Arr(i, 6), Fin) - Application.Max(x, Debut))) > 0     'vérifier cheveauchement
               If b Then Exit For            'si vrai, il ne faut plus continuer
          End If
     Next
     Cheveauchement = b
End Function

Bonjour Bsalv,

Merci pour ta réponse, une 3ème fonction personnalisée.

Mais est-ce que les "functions" sont compatibles avec les formulaires ?

Merci

Bonjour à tous,

Aprés avoir réussit à transformer vos 3 fonctions en macro de formulaire et quelques modifs , voilà mes quelques résultats :

Pour jExcel2Fr, j'arrive à avoir des résultats, mais les chevauchements ne sont pas tous bons, toujours par rapport à ma 1ere ligne de BD (15h00 durée 2h)

Private Sub test_Click()
'Function PlageExiste(salle As String, dateNouveau As Date, heureNouveau As Date, dureeNouveau As Double) As Boolean
    Dim salle As String, dateNouveau As Date, heureNouveau As Date, dureeNouveau As Double, PlageExiste As Boolean
    Dim i%, ws2 As Worksheet, tb2 As ListObject
    Dim dateExistant As Date, heureExistant As Date, dureeExistant As Double, debutNouveau As Date, finNouveau As Date, debutExistant As Date, finExistant As Date
     Application.ScreenUpdating = False
     Set ws2 = Sheets("Réserv.")
     Set tb2 = ws2.ListObjects("Reserv")
    ' Calculer l'heure de début et de fin du nouveau rendez-vous
    debutNouveau = CDate(Me.datR.Value) + CDate(Me.Hor.Value)
    finNouveau = CDate(debutNouveau) + (CDate(Me.dur.Value) * 24 / 60)
    ' Parcourir tous les rendez-vous existants
MsgBox debutNouveau & " " & finNouveau '16h30 17h18
    For i = 1 To tb2.ListRows.Count
        salle = tb2.DataBodyRange(i, 2).Value
        dateExistant = CDate(tb2.DataBodyRange(i, 4).Value)
        heureExistant = CDate(tb2.DataBodyRange(i, 5).Value)
        dureeExistant = CDate(tb2.DataBodyRange(i, 6).Value)
        ' Calculer l'heure de début et de fin du rendez-vous existant
        debutExistant = dateExistant + heureExistant
        finExistant = debutExistant + (dureeExistant * 24 / 60) 
'MsgBox debutExistant & " " & finExistant: GoTo Fin '15h00 '16h48
        ' Vérifier les chevauchements
        If salle = Me.salle.Value And (debutNouveau < finExistant) And (finNouveau > debutExistant) Then 'si 16h30 < 16h48 et 17h18 > 15h00
            PlageExiste = True 'ChevauchementExiste = True
            MsgBox "Salle prise"
            GoTo Fin
        Else
            MsgBox "Salle dispo"
            Exit For
        End If
    Next i
    PlageExiste = False
'End Function
Fin:
     Application.ScreenUpdating = True
End Sub

Pour Eriiic, je n'ai pas de message de résultat.

Private Sub test_Click()
'Function validerH(salle As String, dat, hDeb, durée) As Boolean
    Dim datas, lig As Long, salle$, dat As Date, hDeb As Date, durée As Date, validerH As Boolean
    Dim t11 As Long, t12 As Long, t21 As Long, t22 As Long '
    Dim pl As Range, ok As Boolean
    datas = [B2].Resize(Cells(Rows.Count, 2).End(xlUp).Row - 1, 5)
    ok = True
    hDeb = CDate(Me.Hor.Value)
    durée = CDate(Me.dur.Value)
    t11 = hDeb * 24 * 60 'horaire debut UF
    t12 = (hDeb + durée) * 24 * 60 'horaire fin UF
    For lig = 1 To UBound(datas)
        If salle = datas(lig, 1) And dat = datas(lig, 3) Then 'si meme salle meme date
            t21 = datas(lig, 4) * 24 * 60 'horaire debut BD
            t22 = (datas(lig, 4) + datas(lig, 5)) * 24 * 60 'horaire debut + duree = horaire fin BD
            Set pl = Intersect(Range(t11 & ":" & t12), Range(t21 & ":" & t22)) 'calcul plage commune
            If Not pl Is Nothing Then
                If pl.Rows.Count > 1 Then
                    ok = False
                    MsgBox "Salle prise"
                    Exit For
                End If
            End If
        End If
    Next lig
'    If pl.Rows.Count = 0 Then MsgBox "Salle prise"
    validerH = ok
    Set pl = Nothing
'End Function
Fin:
     Application.ScreenUpdating = True
End Sub

Pour Bsalv,

çà bug, parce que je ne vois pas comment l'adapter à mon tableau

Private Sub test_Click()
'Function Cheveauchement(salle As String, MaDate, hDebut, Duree, Tableau As Range) As Boolean
     Dim ws2 As Worksheet, tb2 As ListObject
     Dim salle As String, MaDate, hDebut, Duree, Tableau As Range, Cheveauchement As Boolean
     Dim Arr, Debut As Double, Fin As Double, b As Boolean, i, x
     Set ws2 = Sheets("Réserv.")
     Set tb2 = ws2.ListObjects("Reserv")
     Arr = Tableau.Value2                    'tableau >>> array
     Debut = CDate(Me.datR.Value)
     hDebut = CDate(Me.Hor.Value)
     Duree = CDate(Me.dur.Value)
     Debut = MaDate + hDebut                 'début cette reservation
     Fin = Debut + Duree                     'fin cette reservation
     For i = 1 To UBound(Arr)                'boucler réservations actuelles
          If StrComp(Arr(i, 2), salle, 1) = 0 Then     'même salle
               x = Arr(i, 4) + Arr(i, 5)     'début d'une réservation actuelle
               b = (Application.Max(0, Application.Min(x + Arr(i, 6), Fin) - Application.Max(x, Debut))) > 0     'vérifier cheveauchement
               If b Then MsgBox "salle prise": Exit For             'si vrai, il ne faut plus continuer
          End If
     Next
     Cheveauchement = b
'End Function
Fin:
     Application.ScreenUpdating = True
End Sub

Le fichier avec les trois tests dans l'UF en test pour l'actif, test1, test2 et test3 pour les 3 tests

Merci, A+

bonjour Trucky93,

on peut utiliser cette fonction personnalisée dans module1 dans votre userform. Voir PJ.

Les heures et les dates sont des nombres maintenant.

Bonjour Bsalv,

Cà semble fonctionner, j'essaie de comprendre, c difficile, et çà bug aprés le message

J'y suis arrivé de mon côté, en limitant mon schéma à 3 cas et en plaçant les = comme il faut.

Bonjour,

pas sûr que tu aies lu les explications demandées : https://forum.excel-pratique.com/post/repondre/193572?p=1203720
eric

J'y suis arrivé de mon côté, en limitant mon schéma à 3 cas et en plaçant les = comme il faut.

Ma fonction le fait en une fois, càd : prenez le plus petit fin (donc de "hor2" et "col2") et le plus grand debut ("hor1" et "col1"), si la soustraction des 2 est un chiffre positif plus grand que 0, on a un cheveauchement

donc si min(col2;hor2) - max(col1;hor1) > 0 , c'est cheveauchement.

ce bug, il faut déplacer ce "endif" (en vert dans cet image) entre les 2 autres "End If's"

Et vous voyez aussi ce "or 1", vous pouvez le supprimer aussi

Bonjour Bsalv,

J'ai corrigé, bravo çà fonctionne bien.

Merci