Microsoft 365 Macro avec Format Heures [hh] : mm ne fonctionne pas

[jlbcall]

Bonjour,

Dans ce fichier j'ai uen macro qui construit l'enchainement entre des horaires de voyages aller et retour des enchainements.
Mon problème c'est que dés que les heures sont au delà de 23h59 elle ne fonctionne plus.
J'ai mis le format des heures avec des [hh] mais cela ne permet pas à la macro de reconnaitre les horaires.

Merci d'avance de votre aide et bonne journée à tous

 

[dysorthographie]

bonjour,

Range("A1").NumberFormat = "[h]:mm"

 

[sylvanu]

Bonjour,
Plutôt :

cell.NumberFormat = "[h]:mm"

PS : Votre VBA est protégé par mot de passe.

 

[jlbcall]

bonjour,

Range("A1").NumberFormat = "[h]:mm"

La macro étant protéger je viens de la copier

Sub JLB
Dim LO_A, LO_R, Na, Nr, Ta, Tr, Temp, bAller, dMin, dHeure As Double, s, r, CNT(1)

Set LO_A = Range("Aller").ListObject 'les 2 TS
Set LO_R = Range("Retour").ListObject
Na = LO_A.ListColumns.Count 'nombre de colonnes
Nr = LO_R.ListColumns.Count

If LO_A.HeaderRowRange.Cells(1, Na).Value2 <> LO_R.HeaderRowRange.Cells(1, 2).Value2 Then MsgBox "problème 1": Exit Sub 'noms du départ de l'un et le dernier de l'autre
If LO_A.HeaderRowRange.Cells(1, 2).Value2 <> LO_R.HeaderRowRange.Cells(1, Nr).Value2 Then MsgBox "problème 2": Exit Sub

Range("Aller[SV]").ClearContents 'RAZ colonne SV
Range("Retour[SV]").ClearContents

Do 'boucler à partir de heure "0"
s = ""
CNT(0) = CNT(0) + 1 'N° enchaine suivant
CNT(1) = 0 'reset N° sous-enchaine
dHeure = 0 'recommencer avec heure=0
Temp = Array(f_Premier(True, dHeure), f_Premier(False, dHeure)) 'chercher premier départ libre pour les 2
dMin = Application.Min(Temp(0)(0), Temp(1)(0)) 'le plus petit des 2
If dMin < 1 Then 'l'heure est avant minuit
bAller = (Temp(0)(0) = dMin) 'le plus petit des 2 est"Aller"
Arr = IIf(bAller, Temp(0), Temp(1)) 'prendre les données du plus petit

Do 'boucler avec l'heure de l'arrivée de la dernière étape
r = Arr(1) 'ligne avec ce temps de départ
CNT(1) = CNT(1) + 1 'augmenter N° sous-enchaine
If bAller Then 'on est en train d' "aller"
Range("Aller[sv]").Cells(r, 1) = "SV-" & CNT(0) ' & "." & CNT(1) 'ajouter ce texte à la cellule
s = s & vbLf & "SV-" & CNT(0) & "." & CNT(1) & " A " & Format(Range("Aller[sv]").Cells(r, 2), "hh:mm") & " >> " & Format(Range("Aller[sv]").Cells(r, Na), "hh:mm")
dHeure = LO_A.ListRows(r).Range.Cells(1, Na).Value2 'l'heure d'arrivée de cette ligne
Arr = f_Premier(False, dHeure) 'chercher l'heure de départ pour "Retour" >= l'heure arrivée "Aller"
Else
Range("retour[sv]").Cells(r, 1) = "SV-" & CNT(0) '& "." & CNT(1)
s = s & vbLf & "SV-" & CNT(0) & "." & CNT(1) & " R " & Format(Range("Retour[sv]").Cells(r, 2), "hh:mm") & " >> " & Format(Range("Retour[sv]").Cells(r, Nr), "hh:mm")
dHeure = LO_R.ListRows(r).Range.Cells(1, Nr).Value2
Arr = f_Premier(True, dHeure)
End If
bAller = Not bAller
Loop While Arr(0) < 1
MsgBox s, , "Service Voiture " & CNT(0) ' remmettre si on veut voir les enchainements SV par SV
End If
Loop While dMin < 1
MsgBox "Traitement terminé Attention si des voyages sont aprés 23h59"
MsgBox "< Tous Droits réservés JLB Méthodes Transdev Morocco >"
End Sub

Function f_Premier(bAller As Boolean, Depart As Double)
Dim Temp, Arr(1)
s = Replace(Replace("if((len(#[SV])=0)*(offset(#[SV],,2)>=@) ,offset(#[sv],,2),1e9)", "#", IIf(bAller, "Aller", "Retour")), "@", Replace(Depart, ",", "."))
Temp = Evaluate(s)
Arr(0) = Application.Min(Temp)
Arr(1) = Application.IfError(Application.Match(Arr(0), Temp, 0), 0)
f_Premier = Arr
End Function

 

[jlbcall]

Bonjour,
Plutôt :

cell.NumberFormat = "[h]:mm"

PS : Votre VBA est protégé par mot de passe.

j'ai copié la macro ci-dessous ou puisse je intégrer ce format?

 

[cathodique]

Bonjour,

@jlbcall : Ainsi ta macro est plus lisible (en utilisant </>)

Sub JLB
Dim LO_A, LO_R, Na, Nr, Ta, Tr, Temp, bAller, dMin, dHeure As Double, s, r, CNT(1)

Set LO_A = Range("Aller").ListObject 'les 2 TS
Set LO_R = Range("Retour").ListObject
Na = LO_A.ListColumns.Count 'nombre de colonnes
Nr = LO_R.ListColumns.Count

If LO_A.HeaderRowRange.Cells(1, Na).Value2 <> LO_R.HeaderRowRange.Cells(1, 2).Value2 Then MsgBox "problème 1": Exit Sub 'noms du départ de l'un et le dernier de l'autre
If LO_A.HeaderRowRange.Cells(1, 2).Value2 <> LO_R.HeaderRowRange.Cells(1, Nr).Value2 Then MsgBox "problème 2": Exit Sub

Range("Aller[SV]").ClearContents 'RAZ colonne SV
Range("Retour[SV]").ClearContents

Do 'boucler à partir de heure "0"
s = ""
CNT(0) = CNT(0) + 1 'N° enchaine suivant
CNT(1) = 0 'reset N° sous-enchaine
dHeure = 0 'recommencer avec heure=0
Temp = Array(f_Premier(True, dHeure), f_Premier(False, dHeure)) 'chercher premier départ libre pour les 2
dMin = Application.Min(Temp(0)(0), Temp(1)(0)) 'le plus petit des 2
If dMin < 1 Then 'l'heure est avant minuit
bAller = (Temp(0)(0) = dMin) 'le plus petit des 2 est"Aller"
Arr = IIf(bAller, Temp(0), Temp(1)) 'prendre les données du plus petit

Do 'boucler avec l'heure de l'arrivée de la dernière étape
r = Arr(1) 'ligne avec ce temps de départ
CNT(1) = CNT(1) + 1 'augmenter N° sous-enchaine
If bAller Then 'on est en train d' "aller"
Range("Aller[sv]").Cells(r, 1) = "SV-" & CNT(0) ' & "." & CNT(1) 'ajouter ce texte à la cellule
s = s & vbLf & "SV-" & CNT(0) & "." & CNT(1) & " A " & Format(Range("Aller[sv]").Cells(r, 2), "hh:mm") & " >> " & Format(Range("Aller[sv]").Cells(r, Na), "hh:mm")
dHeure = LO_A.ListRows(r).Range.Cells(1, Na).Value2 'l'heure d'arrivée de cette ligne
Arr = f_Premier(False, dHeure) 'chercher l'heure de départ pour "Retour" >= l'heure arrivée "Aller"
Else
Range("retour[sv]").Cells(r, 1) = "SV-" & CNT(0) '& "." & CNT(1)
s = s & vbLf & "SV-" & CNT(0) & "." & CNT(1) & " R " & Format(Range("Retour[sv]").Cells(r, 2), "hh:mm") & " >> " & Format(Range("Retour[sv]").Cells(r, Nr), "hh:mm")
dHeure = LO_R.ListRows(r).Range.Cells(1, Nr).Value2
Arr = f_Premier(True, dHeure)
End If
bAller = Not bAller
Loop While Arr(0) < 1
MsgBox s, , "Service Voiture " & CNT(0) ' remmettre si on veut voir les enchainements SV par SV
End If
Loop While dMin < 1
MsgBox "Traitement terminé Attention si des voyages sont aprés 23h59"
MsgBox "< Tous Droits réservés JLB Méthodes Transdev Morocco >"
End Sub

Function f_Premier(bAller As Boolean, Depart As Double)
Dim Temp, Arr(1)
s = Replace(Replace("if((len(#[SV])=0)*(offset(#[SV],,2)>=@) ,offset(#[sv],,2),1e9)", "#", IIf(bAller, "Aller", "Retour")), "@", Replace(Depart, ",", "."))
Temp = Evaluate(s)
Arr(0) = Application.Min(Temp)
Arr(1) = Application.IfError(Application.Match(Arr(0), Temp, 0), 0)
f_Premier = Arr
End Function