Discussion :

[Klin89]

Bonsoir à tous,

J'explique ma problématique :

Je cherche à déterminer le nombre de kilomètres parcourus en commun par des enfants empruntant un ramassage scolaire, le parcours desservant plusieurs points de ramassage et de dépose.

Contraintes :

- Le nombre d'enfants transportés peut varier de 1 à 8, il s'agit d'un minibus.
- Plusieurs enfants peuvent-être pris en charge ou déposés au même point desservi.
- Le parcours commence toujours par un point de prise en charge et prend fin par une dépose (c'est évident)
- Dans cet intervalle, au gré du parcours, plusieurs prises en charge et déposes se succèdent, mais pour compliquer le tout, une dépose peut précéder une prise en charge qui elle-même peut précéder une nouvelle dépose.

Pour illustrer mes propos, je vous joins un exemple simple reposant sur le transport de 3 élèves.



Un relevé de mes données se présentent comme ceci :
* 1ère colonne : le nom de l'élève
* 2ème colonne : le point kilométrique du point de prise en charge de l'élève concerné
* 3ème colonne : le point kilométrique du point de dépose de l'élève concerné



Et voilà ce que j'aimerais obtenir :
La dernière colonne n'est pas nécessaire, c'est juste pour vérifier le résultat à obtenir.



Personnellement, j'y parviens manuellement mais que de temps passé et de sources d'erreurs
J'en appelle donc à votre aide, vous, les experts en algorithmie, pour résoudre cet épineux problème via VBA.

Merci d'avance à tous ceux qui s'y attelleront.
Klin89

[anasecu]

Bonsoir

Je cherche à déterminer le nombre de kilomètres parcourus en commun par des enfants empruntant un ramassage scolaire,
J'en appelle donc à votre aide, vous, les experts en algorithmie, pour résoudre cet épineux problème via VBA

Pas sûr du tout que tu ais besoin de VBA.
Je te propose d'organiser différemment tes données et quelques petites formules suffisent.
Par exemple comme ceci et je te joins le classeur exemple.



Tu as ainsi les points d'arrêts à saisir et les élèves et si tu as plusieurs montées ou descentes, tu rajoutes une ligne avec le même point d'arrêt.

[eriiic]

Bonjour à tous,

anasecu, l'idée est bonne mais j'ai voulu faire descendre Tom au pk5.
J'ai donc inséré une ligne et supprimé la dernière, les distances ne sont plus bonnes.
Je te propose de remplacer la formule en E2 par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=SI(D2>0;DECALER([@km];1;)-[@km];"")

eric

[Klin89]

Bonjour eriic, anasecu

Merci pour l'intérêt porté à mon problème mais ce n'est pas vraiment ce que je recherche
Même si les calculs sont bons, visuellement on ne voit pas bien qui voyage avec qui sur une même partie du parcours
Pour un traitement ultérieur, j'ai vraiment besoin de cette présentation.

Pour résumer, à partir de ce tableau :


Voilà le résultat que je souhaite obtenir : soit le tableau de 4 colonnes, la colonne de droite à part me servait de vérification, il ne faut pas en tenir compte.

L'alternance des couleurs, c'est pour bien visualiser chaque élève, on en tient pas compte également

klin89

[Theze]

Bonjour,

Un simple Somme.Si() ne suffit pas ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
=SOMME.SI(B2:B10;"Tom";A2:A10)

En VBA avec inscription des résultat dans des Shapes ovales. Les trois Shapes sont nommés Tom, Néo et Léa. Les kilomètres en colonne A à partir de A2 et le prénoms en colonne B à partir de B2 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Sub Test()
 
    Dim S As Shape
 
    Set S = ActiveSheet.Shapes("Tom")
    S.TextFrame.Characters.Text = Application.SumIf(Range("B2:B10"), "Tom", Range("A2:A10"))
    S.Fill.ForeColor.RGB = RGB(100, 200, 200)
    S.TextEffect.FontBold = msoCTrue
    S.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
 
    Set S = ActiveSheet.Shapes("Néo")
    S.TextFrame.Characters.Text = Application.SumIf(Range("B2:B10"), "Néo", Range("A2:A10"))
    S.Fill.ForeColor.RGB = RGB(100, 200, 200)
    S.TextEffect.FontBold = msoCTrue
    S.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
 
    Set S = ActiveSheet.Shapes("Léa")
    S.TextFrame.Characters.Text = Application.SumIf(Range("B2:B10"), "Léa", Range("A2:A10"))
    S.Fill.ForeColor.RGB = RGB(100, 200, 200)
    S.TextEffect.FontBold = msoCTrue
    S.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
 
End Sub

[anasecu]

Bonjour,

Pour un traitement ultérieur, j'ai vraiment besoin de cette présentation.

Je ne vois pas le traitement ultérieur dans ma boule de cristal ! ;-)

Voilà le résultat que je souhaite obtenir : soit le tableau de 4 colonnes,

Bien voilà ton souhait sur le classeur joint en utilisant la modélisation des données que je t'avais proposée.
Pour ceux qui ne lisent pas les classeurs, voici le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Option Explicit
Dim idd As Long
Dim ide As Long
Dim idr As Long
Dim nom As String
Dim pkm As Integer
Dim mfn As Byte
Dim tmf(2)
Dim tbd
Dim tbe
Dim tbr
Dim elm
Public Sub Calculs()
    With ActiveSheet
        .Cells(2, 5).Resize(.Cells(Rows.Count, 5).End(xlUp).Row, 4).ClearContents
        Call parcours
        Call résultat
        Call mfc
    End With
End Sub
Public Sub résultat()
Dim eec As String, nec As Byte, typ As String
    idr = 1: mfn = 0: tmf(0) = "=OU(": tmf(1) = "=OU(" '$F2=""tom"";$F2=""léa"")"
    For ide = 1 To UBound(tbe)
        eec = " | " & tbe(ide, 1): nec = 0: mfn = IIf(mfn, 0, 1)
        tmf(mfn) = tmf(mfn) & IIf(Len(tmf(mfn)) > 4, ";", "") & "$F2=""" & tbe(ide, 1) & """"
        For idd = 1 To UBound(tbd)
            elm = Split(tbd(idd), " ")
            If elm(1) = "/" Then
                nec = nec + 1
                If tbe(ide, 1) <> elm(2) Then eec = eec & " | " & elm(2) Else nom = elm(2)
            Else
                nec = nec - 1: eec = Replace(eec, " | " & elm(2), "")
                If elm(2) = tbe(ide, 1) Then tbr(idr - 1, 1) = elm(0) - pkm: Exit For
            End If
            If nom = tbe(ide, 1) Then
                If idr > 1 Then
                    If tbr(idr - 1, 1) = "" Then tbr(idr - 1, 1) = elm(0) - pkm
                End If
                tbr(idr, 2) = tbe(ide, 1)
                tbr(idr, 3) = nec
                tbr(idr, 4) = Mid(eec, 4)
                idr = idr + 1: pkm = elm(0)
            End If
        Next idd
    Next ide
    ActiveSheet.[E2].Resize(idr - 1, 4).Value = tbr
End Sub
Public Sub parcours()
    tbe = ActiveSheet.Range("T_e").Value
    ReDim tbd(1 To 1)
    For ide = 1 To UBound(tbe)
        tbd(UBound(tbd)) = tbe(ide, 2) & " / " & tbe(ide, 1)
        ReDim Preserve tbd(1 To UBound(tbd) + 1)
        tbd(UBound(tbd)) = tbe(ide, 3) & " \ " & tbe(ide, 1)
        ReDim Preserve tbd(1 To UBound(tbd) + 1)
    Next ide
    For ide = 1 To UBound(tbd) - 1
        For idd = ide To UBound(tbd) - 1
            If tbd(ide) > tbd(idd) Then nom = tbd(ide): tbd(ide) = tbd(idd): tbd(idd) = nom
        Next idd
        elm = Split(tbd(ide), " ")
        If Not IsNumeric(elm(0)) Or elm(0) = "" Then MsgBox "Donnée PK incorrecte : " & elm(0) & " pour " & elm(2): End
    Next ide
    ReDim tbr(1 To UBound(tbe) * 5, 1 To 4)
End Sub
Sub mfc()
    With ActiveSheet.Cells(2, 5).Resize(ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row, 4)
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(1) & ")"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 49407
            .TintAndShade = 0
        End With
        .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(0) & ")"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.14996795556505
        End With
    End With
End Sub

L'alternance des couleurs, c'est pour bien visualiser chaque élève, on en tient pas compte également

Pourquoi ne pas en tenir compte ? c'est cadeau !

Tu peux rajouter des élèves dans ton tableau et si tu en as plusieurs qui montent ou descendent ensemble
tu auras une ligne à zéro km pour temporiser le mouvement. .-)

[mercatog]

Bonjour

Pour un début en utilisant les fonctions natives d'Excel: On copie les Pk ramassage et Pk dépôt sur la colonne M. On parcours ensuite, pour chaque Pk, les élèves du tableau initial pour vérifier si le Pk en question se trouve sur le trajet de l'élève X.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub Test()
Dim M As Long, N As Long, Cpt As Long
Dim c As Range, v As Range
Dim Tmp As String
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    M = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("M:P").ClearContents
    .Range("M1").Resize(, 4).Value = Array("Pk", "Distance", "Nbre", "Eleves")
    .Range("B2:B" & M).Copy .Range("M2")
    .Range("C2:C" & M).Copy .Range("M" & M + 1)
 
    N = 2 * M - 1
 
    With .Range("M1:M" & N)
        .RemoveDuplicates Columns:=1, Header:=xlYes
        .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
    End With
 
    N = .Cells(.Rows.Count, 13).End(xlUp).Row
    With .Range("N3:N" & N)
        .FormulaR1C1 = "=RC[-1]-R[-1]C[-1]"
        .Value = .Value
    End With
 
    For Each c In .Range("M2:M" & N)
        Cpt = 0
        Tmp = ""
        For Each v In .Range("B2:B" & M)
            If c.Value > v.Value And c.Value <= v.Offset(, 1).Value Then
                Cpt = Cpt + 1
                Tmp = Tmp & "|" & v.Offset(, -1)
            End If
        Next v
 
        c.Offset(, 2).Resize(, 2).Value = Array(Cpt, Tmp & "|")
    Next c
End With
End Sub

Enfin, une simple Somme.si donnera la distance parcourue par chaque élève