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

[Klin89]

Bonsoir à tous,

Je ne m'attendais pas à une réponse aussi rapide, ça m'a l'air d'être formidable
Etant encore sous Excel2003 chez moi, j'ai inhibé la macro mfc et affecter la variable tbe comme ceci :

Code :

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

tbe = ActiveSheet.Range("T_e").Value

par :

Code :

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

1
2
3
4
5
With ActiveSheet.Range("a1").CurrentRegion
        With .Offset(1).Resize(.Rows.Count - 1)
            tbe = .Value
        End With
End With

Je vais ainsi pousser les tests un peu plus loin de chez moi et te donnerai des nouvelles un peu plus tard.

Sinon, j'ai une demande supplémentaire si c'est possible car je n'ai pas envie de massacrer ton code

A partir du tableau source où j'ai rajouté une colonne :


Pourrait-on obtenir ceci :


Je m'explique : colonne D du tableau source est associé un tarif au km à chaque enfant
X = 0.80
y = 1.30

Un abattement est aussi appliqué en fonction du Nbre d'élèves en commun déterminé en colonne H du tableau cible.
10 % si nBre = 1
23 % si nBre = 2
37 % si nbre >= 3

J'aimerais donc facturer les lignes en colonne K de cette façon, il s'agit du fameux traitement ultérieur.
Pour l'exemple, les lignes à facturer s'élèvent donc à :
en K5 : 10 x 0.8 x 0.77 = 6.16
en K7 : 15 x 0.8 x 0.77 = 9.24
en K9 : 10 x 1.30 x 0.63 = 8.19

D'autre part, est-il possible de déterminer les totaux par enfant comme affiché en colonne J et L
D'avance merci.

Mercatog : je vais regarder aussi votre travail
Edit : au bureau, nous possédons Excel2016 je crois, je testerai aussi dès que possible.

klin89

[anasecu]

Bonjour,

Etant encore sous Excel2003 chez moi, j'ai inhibé la macro mfc et affecter la variable tbe

Si tu l'avais précisé sur ta demande que tu fonctionnais avec un dinosaure j'aurais fais différemment.
Je ne peux pas tester mais je pense que mon nouveau code devrait fonctionner sur 2003 même la MFC.

Sinon, j'ai une demande supplémentaire si c'est possible car je n'ai pas envie de massacrer ton code

Je t'ai donc rajouté tes calculs dans ce code et dans le classeur joint.

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
86
87
88
89
90
91
92
93
Option Explicit
Dim idd As Long
Dim ide As Long
Dim idr As Long
Dim nom As String
Dim mfn As Byte
Dim tmf(2)
Dim tbd
Dim tbe
Dim tbr
Dim elm
Public Sub Calculs()
    With ActiveSheet
        .Cells(2, 6).Resize(.Cells(Rows.Count, 6).End(xlUp).Row, 7).ClearContents
        Call parcours
        Call résultat
        Call mfc
    End With
End Sub
Public Sub résultat()
Dim eec As String, nec As Byte, nkm As Integer, pkm As Double, nok As Boolean
    idr = 1: mfn = 0: tmf(0) = "=OU(": tmf(1) = "=OU("
    For ide = 2 To UBound(tbe)
        eec = "": nec = 0: mfn = IIf(mfn, 0, 1): nok = False: nkm = 0: pkm = 0
        tmf(mfn) = tmf(mfn) & IIf(Len(tmf(mfn)) > 4, ";", "") & "$G2=""" & tbe(ide, 1) & """"
        For idd = 1 To UBound(tbd) - 1
            elm = Split(tbd(idd), " ")
            If elm(1) = "/" Then
                nec = nec + 1: eec = eec & "| " & elm(2) & " ": If elm(2) = tbe(ide, 1) Then nok = True
            Else
                nec = nec - 1: eec = Replace(eec, "| " & elm(2) & " ", "")
            End If
            If nok Then
                If tbd(idd + 1) = "" Then
                    tbr(idr, 1) = Split(tbd(idd) & " ", " ")(0) - Split(tbd(idd - 1) & " ", " ")(0)
                Else
                    tbr(idr, 1) = Split(tbd(idd + 1) & " ", " ")(0) - Split(tbd(idd) & " ", " ")(0)
                End If
                nkm = nkm + tbr(idr, 1)
                tbr(idr, 2) = tbe(ide, 1)
                tbr(idr, 3) = nec
                tbr(idr, 4) = Mid(eec, 3)
                tbr(idr, 6) = tbr(idr, 1) * tbe(ide, 4) * IIf(nec = 1, 0.9, IIf(nec = 2, 0.77, 0.63))
                pkm = pkm + tbr(idr, 6)
                If tbr(idr, 1) > 0 Then idr = idr + 1
                If Split(tbd(idd + 1) & " ", " ")(2) = tbe(ide, 1) And Split(tbd(idd + 1) & " ", " ")(1) = "\" Then
                    tbr(idr - 1, 5) = nkm
                    tbr(idr - 1, 7) = pkm
                    Exit For
                End If
            End If
        Next idd
    Next ide
    ActiveSheet.[F2].Resize(idr - 1, UBound(tbr, 2)).Value = tbr
End Sub
 
Public Sub parcours()
    tbe = ActiveSheet.Range("A1").CurrentRegion.Value
    ReDim tbd(1 To 1)
    For ide = 2 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) * 15, 1 To 8)
End Sub
Sub mfc()
    With ActiveSheet.Cells(2, 6).Resize(ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row - 1, 7)
        .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
            .Color = 44999
            .TintAndShade = 0
        End With
    End With
End Sub

[mercatog]

La suite de ma proposition

En I1:J3 le barème des abattements

1	0.1
2	0.23
3	0.37

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
Sub Test()
Dim M As Long, N As Long, Cpt As Long
Dim c As Range, v As Range
Dim Tmp As String
Dim D As Double
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    M = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("M:Q").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("M3: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
 
    For Each v In .Range("A2:A" & M)
        For Each c In .Range("P3:P" & N)
            If InStr(c.Value, "|" & v.Value & "|") Then D = D + (1 - Barem(c.Offset(, -1).Value)) * c.Offset(, -2).Value * v.Offset(, 3).Value
        Next c
        v.Offset(, 4).Value = v.Offset(, 2).Value - v.Offset(, 1).Value
        v.Offset(, 5).Value = D
        D = 0
    Next v
End With
End Sub
 
Private Function Barem(ByVal T As Integer) As Double
 
Barem = Evaluate("Lookup(" & T & ",I1:I3,J1:J3)")
End Function

[anasecu]

Bonjour Klin89,

Voilà j'ai réussi à trouver un excel 2003 pour tester et je te joins le classeur qui fonctionne dans cette version.
Il y avait quelques instructions non compatibles sur le précédent et là cela devrait fonctionner chez toi.

[mercatog]

Et pour Excel 2003. n'incluant pas RemoveDuplicates

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
Sub Test()
Dim M As Long, N As Long, Cpt As Long
Dim c As Range, v As Range
Dim Tmp As String
Dim D As Double
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    M = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("M:P").ClearContents
    .Range("B2:B" & M).Copy .Range("M2")
    .Range("C2:C" & M).Copy .Range("M" & M + 1)
 
    N = 2 * M - 1
    RemoveDoublons .Range("M2:M" & N)
    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("N2: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
    .Range("M1").Resize(, 4).Value = Array("Pk", "Distance", "Nbre", "Eleves")
    .Range("E1").Resize(, 2).Value = Array("Distance", "Total facturé")
    For Each v In .Range("A2:A" & M)
        For Each c In .Range("P3:P" & N)
            If InStr(c.Value, "|" & v.Value & "|") Then D = D + (1 - Barem(c.Offset(, -1).Value)) * c.Offset(, -2).Value * v.Offset(, 3).Value
        Next c
        v.Offset(, 4).Value = v.Offset(, 2).Value - v.Offset(, 1).Value
        v.Offset(, 5).Value = D
        D = 0
    Next v
End With
End Sub
 
Private Sub RemoveDoublons(ByVal Rng As Range)
Dim i As Long
 
For i = Rng.Count To 1 Step -1
    If Rng(i).Value = 0 Or Rng(i).Value = "" Or Application.CountIf(Rng, Rng(i).Value) > 1 Then Rng(i).Delete shift:=xlUp
Next i
End Sub
 
Private Function Barem(ByVal T As Integer) As Double
 
Barem = Evaluate("Lookup(" & T & ",I1:I3,J1:J3)")
End Function

[anasecu]

Bonsoir mercatog,

Comme Klin89 a l'air d'être parti avec son minibus, je me permet de te signaler une petite coquille dans ton code

Code :

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

        For Each c In .Range("P3:P" & N)

Avec P2 à la place de P3 Tom perdrait la gratuité que tu lui accordes sur son début de parcours. ;-)

[mercatog]

Bonsoir anaescu

En effet,
En passant à la version 2003 j'avais supprimé dans la foulée le Pk 0 (ligne 2).

Tant pis pour Tom.

Tu as tout à fait raison

[Klin89]

Re à tous,

Rassurez vous, je suis en phase de tests sur différents scénarios.
Je reviens vers vous dès que possible avec un PDF les illustrant.
Sans jolis croquis, j'ai les neurones qui explosent

A bientôt

klin89

[Algoplus]

bonjour à tous,

Un peu tard, mais une autre solution tableaux et dictionary:

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
Sub Détail_Parcours()
Dim T, T1, TT(), Tnb, Remise, Maxi As Integer, i As Integer, j As Integer
Dim Util As String, CumUtil As String, Cumul As Integer, CuMont As Single, x As Integer
Dim Dico, CC
 
Remise = Array(0.9, 0.77, 0.63)
T = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row) 'tableau des données initiales
Maxi = Application.Max(Application.Index(T, , 3))
ReDim T1(1 To UBound(T, 1), 1 To Maxi)
 
'** création tableau pour chaque Km et chaque utilisateur
For i = LBound(T1, 1) To UBound(T1, 1)
    For j = T(i, 2) + 1 To T(i, 3)
        T1(i, j) = T(i, 1)
    Next
Next
 
'** création par utilsateur
For j = LBound(T, 1) To UBound(T, 1)
   Util = T(j, 1)
   Cumul = 0
    CuMont = 0
   Set Dico = CreateObject("Scripting.Dictionary")
    For i = LBound(T1, 2) To UBound(T1, 2)
        If T1(1, i) = Util Or T1(2, i) = Util Or T1(3, i) = Util Then
            clé = T1(1, i) & "|" & T1(2, i) & "|" & T1(3, i)
            clé = T1(1, i) & "|" & T1(2, i) & "|" & T1(3, i)
            Dico(clé) = Dico(clé) + 1
        End If
    Next
    For Each CC In Dico.keys
        CumUtil = ""
        nb = 0
        x = x + 1
        tnb = Split(CC, "|")
        For k = LBound(tnb) To UBound(tnb) 'determination nb utilsateur et noms
            If tnb(k) <> "" Then
                nb = nb + 1
                If nb = 1 Then
                    CumUtil = tnb(k)
                Else
                    CumUtil = CumUtil & "|" & tnb(k)
                End If
            End If
        Next
        ReDim Preserve TT(1 To 8, 1 To x)
        TT(1, x) = Util 'utilisateur
        TT(2, x) = Dico(CC) 'distance
        TT(3, x) = nb ' nb utilisateur
        TT(4, x) = CumUtil 'noms des utilisateurs
        Cumul = Cumul + Dico(CC) 'total km
        TT(6, x) = Dico(CC) * T(j, 4) * IIf(nb > 2, Remise(2), Remise(nb - 1)) 'montant facturé
        CuMont = CuMont + TT(6, x) ' cumul montant
    Next
    '** écriture des cumuls dans dernière ligne utilisateur
    TT(5, x) = Cumul
    TT(7, x) = CuMont
    Set Dico = Nothing
Next
Range("B16").Resize(UBound(TT, 2), UBound(TT, 1)) = Application.Transpose(TT)
 
End Sub

[Klin89]

Re anasecu,

Les tests s'avèrent positifs anasecu
J'ai élaboré 7 scénarios manuellement dans le PDF ci-joint, j'obtiens les mêmes résultats que ta macro

Petit bémol : dans l'exemple, si je remplace en C2 la valeur 60 par une valeur >= 100, ça le fait pas pourtant le scénario est identique

La macro mfc beug lorsque qu'il n'y a qu'une seule ligne restituée, soit un seul élève dans le bus, ça peut arriver.

D'autre part, pourrait-on insérer entre J et K, 2 colonnes dans le tableau restitué :

- indiquant le tarif
- indiquant l'abattement
au regard de chaque ligne

Dernier point, dans la colonne "élèves en commun" peut-on placer en début de chaine le nom de l'élève concerné comme dans mes exemples, ça serait vraiment le top.

Franchement chapeau anasecu

Je continue les tests et regarde les réponses de Algoplus et mercatog
Dans le PDF, j'ai volontairement occulté le "volet facturation" pour plus de visibilité.
RSCOL.pdf

klin89

[Klin89]

Bonsoir Algoplus

Merci pour ta réponse, mais le peu de tests effectués avec les divers scénarios illustrés du fichier joint ne me renvoie pas les bons résultats.
En plus ça bug dans certains cas

klin89

[Klin89]

Bonsoir mercatog

J'ai testé différents scénarios.

Cela renvoie bien toutes les lignes de Tom lorsque celui-ci emprunte le trajet dans son intégralité.
Les lignes des autres élèves n'apparaissent donc pas

Par contre si Tom emprunte seulement une partie du trajet, on voit apparaître toutes ses lignes, et de façon parcellaire, certaines lignes des autres élèves selon la complexité des cas.

Merci quand même de ta participation.
klin89

[mercatog]

Bonsoir

Non, je conçois que ma proposition ne fait pas exactement ce que tu as demandé (calculs intermédiaires)

Par contre elle donne bien les totaux de chaque élève.

Les lignes des autres élèves n'apparaissent donc pas

Un petit traitement supplémentaire te donneras la disposition du tableau intermédiaire comme ton schéma. Basique