VBA : Retrancher n tant que y > x

[cibleo]

Bonsoir le forum,

J'ai un petit exercice à vous soumettre en VBA.
Explication : je dessers une localité en passant par 4 points (toujours dans un ordre établi) et dois déposer 1 personne à chacun de ces points.
Il faut 15 minutes pour rejoindre chaque point (c'est une constante) mais chaque personne, devant être déposée, dispose de RDV fixés qui n'ont pas d'ordre chronologique (plage jaune).

Question : comment calculer des horaires de dépose (plage verte) permettant à chacun de ne pas arriver en retard aux RDV fixés initialement.

En Feuil1, je suis parvenu à résoudre cet algorithme manuellement en procédant par étapes.
1ère étape : Calcul d'horaire en plage [G6:G3] aprés je pense qu'il faille passer par une boucle Do....loop, mais là je nage

Sub Calcul_Horaire()
'Affiche les horaires dans [G6:G3]
'en retranchant 15 minutes à chaque itération
temps = (1 / 1440) * 15 '= 15 minutes
For i = 6 To 3 Step -1
'A la 1ère itération, je laisse la valeur initiale
'soit la valeur de F6 ici
If i = 6 Then Cells(i, 7) = Cells(i, 6) Else _
Cells(i, 7) = Cells(i + 1, 7) - temps
Next
End Sub

Pouvez-vous m'aider, Cibleo

 

[ROGER2327]

Re : VBA : Retrancher n tant que y > x

Bonsoir à tous, bonsoir cibleo

Et pourquoi pas une petite formule ?​

ROGER2327
#6444

Lundi 23 Gueules 140 (Occultation de Saint J Torma, euphoriste - fête Suprême Quarte)
29 Pluviôse An CCXXI, 9,4681h - chélidoine
2013-W07-7T22:43:24Z


P.s. : Proposition supprimée : voir le message #5.

 

[job75]

Re : VBA : Retrancher n tant que y > x

Bonjour cibleo, Roger,

Dans le fichier joint :

- sélectionner la plage C3:C6

- entrer dans la barre de formule :

=DEPOSE(B3:B6;"0:15:0")

et valider matriciellement par Ctrl+Maj+Entrée.

DEPOSE est cette fonction VBA :

Function DEPOSE(RDV As Range, trajet As Date)
Dim t() As Date, dep As Date, i As Long
ReDim t(1 To RDV.Count, 1 To 1)
dep = RDV(1)
1 For i = 1 To RDV.Count
  t(i, 1) = dep + trajet * (i - 1)
  If Round(1440 * t(i, 1)) > Round(1440 * RDV(i)) _
    Then dep = RDV(i) - trajet * (i - 1): GoTo 1
Next
DEPOSE = t 'matrice
End Function

Noter que quand on veut comparer des heures on a des problèmes...

Ici en multipliant par 1440 et en arrondissant on compare des nombres entiers.

A+

 

[job75]

Re : VBA : Retrancher n tant que y > x

Re,

Une solution par formule avec cette formule matricielle en C3 :

=MIN(B$3:B$6-"0:15:0"*(LIGNE(B$3:B$6)-3))+"0:15:0"*(LIGNE()-3)

A valider par Ctrl+Maj+Entrée et tirer vers le bas.

A+

 

[ROGER2327]

Re : VBA : Retrancher n tant que y > x

Bonjour à tous.

Vu les solutions proposées par job75, je retire ma proposition stupide du message #2.

À la place, voici une réduction de la précédente formule de job75 :​

=MIN(B$3:B$6-(LIGNE(B$3:B$6)-LIGNE())/96)

Bonne journée.


ROGER2327
#6451

Mardi 24 Gueules 140 (Conversion de Saint Matorel, bateleur - fête Suprême Quarte)
30 Pluviôse An CCXXI, 4,2272h - traineau
2013-W08-1T10:08:43Z

 

[cibleo]

Re : VBA : Retrancher n tant que y > x

Bonsoir à tous,
Bonsoir Job75, Roger

C'est super génial vos formules, surtout la fonction personnalisée que je pourrais appeler dans un programme.

Voilà j'aimerais adopter la solution fonction personnalisée et y apporter une variante.
Comme vous l'avez vu, il y avait une constante comme temps de liaison (15 minutes)
Or je souhaite définir des temps de liaison différents et je ne vois pas comment modifier la fonction en intégrant ces nouveaus paramètres de temps.

Pouvez-vous m'aider à nouveau.
J'ai placé de nouvelles explications : mais le principe reste le même.
Je vous remercie Cibleo

 

[job75]

Re : VBA : Retrancher n tant que y > x

Bonsoir cibleo,

Avec cette fonction l'argument trajet est une plage (D3: D6) :

Function DEPOSE(RDV As Range, trajet As Range)
Dim t() As Date, dep As Date, i As Long, h As Date
ReDim t(1 To RDV.Count, 1 To 1)
dep = RDV(1)
1 h = 0 'RAZ
For i = 1 To RDV.Count
  h = h + trajet(i) / 1440
  t(i, 1) = dep + h
  If Round(1440 * t(i, 1)) > Round(1440 * RDV(i)) _
    Then dep = RDV(i) - h: GoTo 1
Next
DEPOSE = t 'matrice
End Function

Formule sur toute la sélection C3:C6 à valider matriciellement :

=DEPOSE(B3:B6;D3:D6)

Fichier (2).

A+

 

[cibleo]

Re : VBA : Retrancher n tant que y > x

Re job75,

Comment veux-tu que je trouve cela
Tu me régales vraiment avec tes solutions.

J'essaierais d'adapter cela à une variable tableau mais ce sera pour plus tard.
En fait, le truc c'est que B3:B6 sera une variable tableau à une dimension (4 éléments) qui, en appelant ta fonction personnalisée, se redimensionnera en variable tableau à 2 dimensions.
Si problème, je ressortirais le fil.

Vraiment merci Job75

 

[job75]

Re : VBA : Retrancher n tant que y > x

Re,

Si l'on tient vraiment à utiliser des Shapes pour les temps de trajet :

Function DEPOSE(RDV As Range)
Dim t() As Date, dep As Date, i As Long, h As Date
Application.Volatile
ReDim t(1 To RDV.Count, 1 To 1)
dep = RDV(1)
1 h = 0 'RAZ
For i = 1 To RDV.Count
  If i > 1 Then h = h + Application.Caller.Parent _
    .Shapes("Ellipse " & i - 1).TextFrame.Characters.Text / 1440
  t(i, 1) = dep + h
  If Round(1440 * t(i, 1)) > Round(1440 * RDV(i)) _
    Then dep = RDV(i) - h: GoTo 1
Next
DEPOSE = t 'matrice
End Function

Les Shapes doivent être renommées dans l'ordre : Ellipse 1 Ellipse 2 Ellipse 3...

La fonction est volatile, si l'on modifie un temps de trajet appuyer sur F9.

Fichier (3).

A+

 

[ROGER2327]

Re : VBA : Retrancher n tant que y > x

Bonsoir à tous.

Deux solutions par formules courtes dans le classeur joint.​

ROGER2327
#6452

Jeudi 26 Gueules 140 (L’Amour absolu, deliquium - fête Suprême Tierce)
2 Ventôse An CCXXI, 0,8919h - cornouiller
2013-W08-3T02:08:26Z

 

[cibleo]

Re : VBA : Retrancher n tant que y > x

Bonsoir à tous,

Job75, pour rebondir sur ta solution du post #9, j'aimerais générer une variable tableau en appelant ta fonction personnalisée à travers une macro.
Voir explications en Feuil1

Sub Génerer_3ème_variable()
Dim tablo1, tablo2
'En exécutant ma macro 2 variables tableau à 2 dimensions seront générées
'pour simplifier, je les ai réprésentées comme ceci
tablo1 = Feuil1.Range("A3:B" & [A65536].End(xlUp).Row)
tablo2 = Feuil1.Range("D3:E" & [D65536].End(xlUp).Row)
'comment obtenir tablo3 variable à 2 dimensions à 3 colonnes
'en appelant la fonction personnalisée
'Voir illustration Feuil1
End Sub

Roger, j'analyse tes formules, pas mal les formats personnalisés, ça va me servir.
Merci à tous

Cibleo

 

[job75]

Re : VBA : Retrancher n tant que y > x

Bonsoir cibleo,

Exécute cette macro dans le fichier (4) joint :

Sub Génerer_3ème_variable()
Dim tablo1, tablo2, tablo3(), dep As Date, h As Date, i&
tablo1 = Feuil1.Range("A3:B" & [A65536].End(xlUp).Row)
tablo2 = [D3:E3].Resize(UBound(tablo1))
ReDim tablo3(1 To UBound(tablo1), 1 To 3)
dep = tablo1(1, 2)
1  h = 0 'RAZ
For i = 1 To UBound(tablo1)
  tablo3(i, 1) = tablo1(i, 1)
  tablo3(i, 2) = tablo1(i, 2)
  h = h + tablo2(i, 2) / 1440
  tablo3(i, 3) = dep + h
  If Round(1440 * tablo3(i, 3)) > Round(1440 * tablo1(i, 2)) _
    Then dep = tablo1(i, 2) - h: GoTo 1
Next
[G3:I3].Resize(UBound(tablo3)) = tablo3 'restitution
End Sub

A+

 

[job75]

Re : VBA : Retrancher n tant que y > x

Re,

Si tu tiens absolument à utiliser la fonction DEPOSE :

Sub Génerer_3ème_variable()
Dim plage1 As Range, plage2 As Range, tablo1, tablo2, tablo3(), t, i&
Set plage1 = Feuil1.Range("A3:B" & [A65536].End(xlUp).Row)
Set plage2 = [D3:E3].Resize(plage1.Rows.Count)
tablo1 = plage1
tablo2 = plage2
t = DEPOSE(plage1.Columns(2).Cells, plage2.Columns(2).Cells)
ReDim tablo3(1 To UBound(tablo1), 1 To 3)
For i = 1 To UBound(t)
  tablo3(i, 1) = tablo1(i, 1)
  tablo3(i, 2) = tablo1(i, 2)
  tablo3(i, 3) = t(i, 1)
Next
[G3:I3].Resize(UBound(tablo3)) = tablo3 'restitution
End Sub

Fichier (4 bis).

A+

 

[cibleo]

Re : VBA : Retrancher n tant que y > x

re

Super génial job75
La solution du post #12 me convient parfaitement, je pensais que l'on pouvait remplacer l'argument range de la fonction personnalisée par une variable tableau

Encore une fois mille Mercis
Cibleo

 

[job75]

Re : VBA : Retrancher n tant que y > x

Bonjour cibleo,

je pensais que l'on pouvait remplacer l'argument range de la fonction personnalisée par une variable tableau

C'est tout à fait possible en effet :

Function DEPOSE(RDV As Variant, trajet As Variant)
Dim t() As Date, dep As Date, i As Long, h As Date
RDV = RDV: trajet = trajet 'transforme en matrices, en cas de plages
ReDim t(1 To UBound(RDV), 1 To 1)
dep = RDV(1, 1)
1 h = 0 'RAZ
For i = 1 To UBound(RDV)
  h = h + trajet(i, 1) / 1440
  t(i, 1) = dep + h
  If Round(1440 * t(i, 1)) > Round(1440 * RDV(i, 1)) _
    Then dep = RDV(i, 1) - h: GoTo 1
Next
DEPOSE = t 'matrice
End Function

Utilisation dans le fichier (5).

A+