Calcul de distances parcourues en commun

**anasecu** · 11/03/2019, 22h14

Bonsoir RyuAutodidacte,

Envoyé par RyuAutodidacte

anasecu, Pourrais tu mettre ton code entre les balises code stp, afin que je puisse le tester.

Tu n'as pas bien regardé car j'ai "balisé" le code comme tu me demandes poste 27 et je n'ai rajouté que la ligne de contrôle demandée : c'est pour cela que je ne l'ai pas remis.

J'en profite donc pour te demander de jeter un coup d’œil sur ma demande pour utilisation de formulaire sur MAC qui n'a pas mobilisé les foules

https://www.developpez.net/forums/d1...-mac-userform/
Merci d'avance

**RyuAutodidacte** · 11/03/2019, 22h24

Si j’ai bien vu

J’aimerai tout simplement tester avec la dernière version (et donc les contrôles qui ont qd même leur importance

)

**RyuAutodidacte** · 12/03/2019, 10h54

Bonjour mercatog,

J’ai testé ton code, j’ai bien aimé la façon de coder et l’enchaînement de celui-ci …
Je t’ai mis

**anasecu** · 13/03/2019, 22h17

Bonsoir,

Envoyé par RyuAutodidacte

J’aimerai tout simplement tester avec la dernière version (et donc les contrôles qui ont qd même leur importance

)

Avec une ligne de plus tu ne vas changer grand chose sinon éliminer une erreur de saisie ;-)

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
94
95
96
97
98
99
100
101
102
103
104
105
Private Sub Worksheet_Change(ByVal sel As Range)
If sel.Count > 1 Then Exit Sub
If Not Intersect(sel, Range("A:D")) Is Nothing Then
    Call Calculs
End If
End Sub
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, 13).End(xlUp).Row, 10).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 Double, pkm As Double, nok As Boolean
    idr = 1: mfn = 0: tmf(0) = "=OU(": tmf(1) = "=OU("
    For ide = 2 To UBound(tbe)
        eec = "| " & tbe(ide, 1): nec = 0: mfn = IIf(mfn, 0, 1): nok = False: nkm = 0: pkm = 0
        tmf(mfn) = tmf(mfn) & IIf(Len(tmf(mfn)) > 4, ";", "") & "$H2=""" & tbe(ide, 1) & """"
        For idd = 1 To UBound(tbd) - 1
            elm = Split(tbd(idd), " ")
            If elm(1) = "/" Then
                nec = nec + 1
                If InStr(eec, elm(2)) = 0 Then 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
                tbr(idr, 1) = Split(tbd(idd + 1) & " ", " ")(0) - Split(tbd(idd) & " ", " ")(0)
                tbr(idr, 2) = Split(tbd(idd) & " ", " ")(0) & " à " & Split(tbd(idd + 1) & " ", " ")(0)
                nkm = nkm + tbr(idr, 1)
                tbr(idr, 3) = tbe(ide, 1)
                tbr(idr, 4) = nec
                tbr(idr, 5) = Mid(eec, 3)
                tbr(idr, 7) = tbe(ide, 4)
                tbr(idr, 8) = IIf(nec = 1, 0.1, IIf(nec = 2, 0.23, 0.37))
                tbr(idr, 9) = tbr(idr, 1) * tbr(idr, 7) * (1 - tbr(idr, 8))
                pkm = pkm + tbr(idr, 9)
                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, 6) = nkm
                    tbr(idr - 1, 10) = 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)
        If Not IsNumeric(tbe(ide, 2)) Or tbe(ide, 2) = "" _
            Or Not IsNumeric(tbe(ide, 3)) Or tbe(ide, 3) = "" _
            Or tbe(ide, 3) <= tbe(ide, 2) Then
                MsgBox "Donnée PK incorrecte pour " & tbe(ide, 1): End
        End If
        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 CDbl(Left(tbd(ide), InStr(tbd(ide), " ") - 1)) > CDbl(Left(tbd(idd), InStr(tbd(idd), " ") - 1)) Then
                nom = tbd(ide): tbd(ide) = tbd(idd): tbd(idd) = nom
            End If
        Next idd
    Next ide
    ReDim tbr(1 To UBound(tbe) * 5, 1 To 10)
End Sub
Sub mfc()
    With ActiveSheet
        .Cells(2, 5).Activate
        With .Cells(2, 6).Resize(.Cells(Rows.Count, 13).End(xlUp).Row, 10)
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(1) & ")"
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ColorIndex = 44
            End With
            If Len(tmf(0)) > 4 Then
                .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(0) & ")"
                With .FormatConditions(2).Interior
                    .PatternColorIndex = xlAutomatic
                    .ColorIndex = 39
                End With
            End If
        End With
    End With
End Sub

**Klin89** · 14/03/2019, 22h45

re anasecu,

J'ai remarqué l'absence d'espace entre le 1er nom et la barre verticale et 1 espace en trop en fin de chaîne
Nom : RSC1.JPG
Affichages : 198
Taille : 12,1 Ko

Pour peaufiner, j'ai donc remplacé ceci :

Code :

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

1
2
3
4
5
6
7
If elm(1) = "/" Then
    nec = nec + 1
    If InStr(eec, elm(2)) = 0 Then eec = eec & "| " & elm(2) & " "
    If elm(2) = tbe(ide, 1) Then nok = True
Else
    nec = nec - 1: eec = Replace(eec, "| " & elm(2) & " ", "")
End If

par cela :

Code :

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

1
2
3
4
5
6
7
If elm(1) = "/" Then
    nec = nec + 1
    If InStr(eec, elm(2)) = 0 Then eec = eec & " | " & elm(2) & ""
    If elm(2) = tbe(ide, 1) Then nok = True
Else
    nec = nec - 1: eec = Replace(eec, " | " & elm(2) & "", "")
End If

Ai-je bon anasecu

RyuAutodidacte, après test, ça m'a l'air tout bon

klin89

**RyuAutodidacte** · 14/03/2019, 23h04

Coucou Klin89,

une petite surprise à venir

**RyuAutodidacte** · 16/03/2019, 00h33

Bonsoir,

Voilà comme dit dans le post précédent, la surprise, je l'ai fait pour le Fun mais ça peut servir

Ajout :

• Si on sélectionne uniquement le nom d'un élève, le résultat sera uniquement pour l'élève choisi (fait avec le premier Application.InputBox)

• 2ème Application.InputBox afin de choisir la destination, sinon le résultat se met à l'emplacement par défaut

Bien sur les 2 options sont cumulables

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
Option Explicit
 
Sub MaVersionFinal()
Dim Res(), Abatt, TB_Source As Range, Vide As Byte, VA, Coll_PK As New Collection, K, Tab_Pk(), Nb_PK As Long, PK As String, i As Long, j As Long, X As Integer, Noms As String, L As Long, SOM As Double, TB_Desti As Range
 
    Res = Application.Transpose(Array("Distance PK en Km", "PK", "Elève", "Nb élèves", "Elèves communs", "Total Km/élève", "Tarif", "Abattement", "Montant facturé", "Montant total/élève"))
    Abatt = Array("10%", "23%", "37%")
    On Error Resume Next
        Set TB_Source = Application.InputBox(prompt:="Sélectionner une cellule", Title:="Choix du tableau source", Type:=8)
        If TB_Source Is Nothing Then MsgBox "Sélection annulée": Exit Sub
    With TB_Source.CurrentRegion
        Vide = .SpecialCells(xlCellTypeBlanks).Count
        If Vide >= 1 Then MsgBox "DONNÉES MANQUANTES" & vbCrLf & vbCrLf & "Vérifier votre tableau source !!!!!!!": Set TB_Source = Nothing: Exit Sub
        VA = .Value
        With .Columns.Item(2).Offset(1).Resize(.Rows.Count - 1, 2)
            For i = 2 To .Rows.Count
                If VA(i, 3) - VA(i, 2) <= 0 Then MsgBox "DONNÉES PK NON CONFORMES" & vbCrLf & vbCrLf & "Vérifier votre tableau source !!!!!!!": Exit Sub
            Next
            Nb_PK = .Cells.Count:       ReDim Tab_Pk(1 To Nb_PK)
            For i = 1 To Nb_PK: Tab_Pk(i) = Application.Small(.Value, i): Next
        End With
        For i = 2 To Nb_PK
            If Tab_Pk(i - 1) <> Tab_Pk(i) Then
            PK = Tab_Pk(i - 1) & " à " & Tab_Pk(i)
                For j = 2 To .Rows.Count
                    If VA(j, 2) <= Tab_Pk(i - 1) And VA(j, 3) >= Tab_Pk(i) Then
                        Coll_PK.Add VA(j, 1), PK
                        If Err Then Err.Clear:      If InStr(Coll_PK(PK), VA(j, 1)) = 0 Then Noms = Coll_PK(PK):    Coll_PK.Remove PK:      Coll_PK.Add Noms & " | " & VA(j, 1), PK
                    End If
                Next
            End If
        Next
    On Error GoTo 0
        If TB_Source.Count = 1 And Not Application.Intersect(TB_Source, .Columns.Item(1)) Is Nothing Then
                If Application.Match(TB_Source.Value, .Columns.Item(1), 0) > 1 Then X = Application.Match(TB_Source.Value, .Columns.Item(1), 0): j = X Else j = 2
        Else
            j = 2
        End If
         For j = j To IIf(X > 0, X, .Rows.Count)
            i = 1
            For Each K In Coll_PK
                i = i + 1: If Tab_Pk(i) = Tab_Pk(i - 1) Then Do: i = i + 1: Loop While Tab_Pk(i) = Tab_Pk(i - 1)
                If InStr(K, VA(j, 1)) > 0 Then
                    If InStr(K, VA(j, 1)) > 1 Then K = VA(j, 1) & " | " & Replace(K, " | " & VA(j, 1), "") Else Noms = K
                    ReDim Preserve Res(1 To 10, 1 To UBound(Res, 2) + 1):       L = UBound(Res, 2)
                    Res(1, L) = Tab_Pk(i) - Tab_Pk(i - 1):          Res(2, L) = Tab_Pk(i - 1) & " à " & Tab_Pk(i):          Res(3, L) = VA(j, 1):           Res(4, L) = Len(K) - Len(Replace(K, "|", "")) + 1:          Res(5, L) = K
                    Res(7, L) = VA(j, 4):               Res(8, L) = Abatt(IIf(Res(4, L) > 2, 2, Res(4, L) - 1)):              Res(9, L) = Res(1, L) * VA(j, 4) * (1 - (Val(Res(8, L)) / 100)):        SOM = SOM + Res(9, L)
                End If
            Next
            Res(6, L) = VA(j, 3) - VA(j, 2):            Res(10, L) = SOM:       SOM = 0
        Next
        If MsgBox("Voulez vous choisir la destination du résultat ?", vbYesNo) = vbYes Then
            Do
                Set TB_Desti = Application.InputBox(prompt:="Sélectionner une cellule", Title:="CHOIX DE LA DESTINATION", Type:=8)
                If TB_Desti.Count > 1 And Not TB_Desti Is Nothing Then MsgBox "Merci de ne sélectionner qu'une seule cellule"
            Loop While TB_Desti.Count <> 1 Or TB_Desti Is Nothing
            If TB_Desti Is Nothing Then Set TB_Desti = .Offset(, .Columns.Count + 3).Resize(1, 1)
        Else
            Set TB_Desti = .Offset(, .Columns.Count + 3).Resize(1, 1)
        End If
        Application.ScreenUpdating = False
            With TB_Desti
                .CurrentRegion.Clear
                .Resize(UBound(Res, 2), UBound(Res)) = Application.Transpose(Res)
                With .CurrentRegion
                    .HorizontalAlignment = xlCenter:        .VerticalAlignment = xlCenter:  .Columns.AutoFit
                    New_inter_Coul 2, .Cells, 3
                    .Borders.Value = 1
                End With
            End With
        Application.ScreenUpdating = True
    End With
    Set TB_Source = Nothing:      Set TB_Desti = Nothing
End Sub

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
Function New_inter_Coul(Deb As Byte, Rg As Range, Col As Byte) 'RyuAutodidacte - code réadapté pour ce post
Dim Cpt As Long, indx As Long, Coul(), Cel As Range
Cpt = 1:    indx = 1:       Coul() = Array(15, 44) ' Possibilité de modifier/ajouter/enlever des couleurs index dans l'Array
    Application.ScreenUpdating = False
        For Each Cel In Rg.Columns.Item(Col).Offset(1).Resize(Rg.Rows.Count - Deb + 1).Rows
            If Cel = Cel.Offset(1) Then
                Cpt = Cpt + 1
            Else
                Rg.Rows(Deb).Resize(Cpt).Interior.ColorIndex = Coul(indx Mod (UBound(Coul) + 1))
                Deb = Deb + Cpt: Cpt = 1: indx = indx + 1
            End If
        Next
    Application.ScreenUpdating = True
End Function
'Cf =>https://www.developpez.net/forums/d1878159/logiciels/microsoft-office/excel/macros-vba-excel/alterner-couleurs/

**anasecu** · 16/03/2019, 09h35

Bonjour Klin89,

Envoyé par Klin89

Ai-je bon anasecu

Je vois bien là ton intéressant perfectionnisme mais tu t'ai compliqué la vie en ne le mettant pas où il manquait
c'est-à-dire lors de la mise en place de l'élève concerné

Code :

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

        eec = "| " & tbe(ide, 1) & " ": nec = 0: mfn = IIf(mfn, 0, 1): nok = False: nkm = 0: pkm = 0

Bonne journée.

**RyuAutodidacte** · 16/03/2019, 12h43

Bonjour,

@ anasecu
je viens de commencer à tester ton dernier code, et je suis tombé sur une erreur sur Sub mfc() (Tester sur Mac)

Code LA LIGNE DE CODE CONCERNÉE :

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

            .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(1) & ")"

La valeur en espion :

Code :

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

:EXPRESSION: tmf(1) & ")"                     :VALEUR:  "=OU($H2="Tom";$H2="Léa")"                  :TYPE:  Variant/String * -1          :CONTEXE:  Module*1.mfc

Message d'erreur : Erreur d'exécution 5 => Argument ou appel de procédure incorrect

• Qd le code est déclenché par l'évènement, j'ai toujours l'erreur

• Qd le code est déclenché manuellement via Sub Calculs(), j'ai une fois l'erreur

,
puis je stop la procédure, et relance une seconde fois via Sub Calculs() et la la MFC passe et la procédure se termine

???

Vois tu d'où cela peut provenir ??

@Klin89
Étant donné que j'ai fait la macro sur Mac, je voulais savoir si tu l'avais testé sur un version récente d'Excel ou sur la version 2003 ?
Et aussi si les nouvelles modif sont OK ??

**anasecu** · 16/03/2019, 19h03

Bonjour RyuAutodidacte,

Envoyé par RyuAutodidacte

Vois tu d'où cela peut provenir ??

La MFC est faite très spécialement pour la version 2003 qui gère différemment le paramétrage,
mais elle continue de fonctionner normalement sur excel 2016.
La version que j'avais faite avant de savoir que Klin89 avait 2003 ne fonctionnait pas sur 2003
et c'est sans doute ta version Mac qui n'est pas compatible avec 2003
car celle-ci est assez minimaliste et limitée à 3 éléments : l'on frôle la limite.

Donc 2 systèmes, 2 versions très éloignées, c'est nécessairement un nid d'incompatibilités.

Dans ta version, si tu véhicules Jean et Jeanine il faut lui interdire de descendre avant car sinon de nouveaux élèves clandestins apparaissent au grand jour

**Klin89** · 16/03/2019, 20h17

re anasecu

Impeccable

En poussant ton code dans ces derniers retranchements, je me suis aperçu que la variable tableau tbr n'était pas assez "calibrée",
le truc tout bête auquel on ne pense pas

Je l'ai donc redimensionnée simplement :

Code :

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

ReDim tbr(1 To UBound(tbe) * 5, 1 To 10)

par :

Code :

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

ReDim tbr(1 To UBound(tbe) * 10, 1 To 10)

Comme quoi, il faut toujours tester, tester et retester

Sinon, je pense avoir fait le tour de ton code.
anescu

Patience, patience RyuAutodidacte, je vais tester aussi

klin89

**Klin89** · 16/03/2019, 23h14

re anasecu

Le coup du Jean Jeanine, je ne l'ai pas vu venir

Démonstration avec le fichier du post #35#

J'ai remplacé Néo par Jean-Paul (avec un tiret)
Cela me renvoie ceci, c'est tout bon

Nom : RSC15.JPG
Affichages : 159
Taille : 29,4 Ko

Nom : RSC15.JPG
Affichages : 159
Taille : 29,4 Ko

Par contre si je remplace Néo par Jean Paul (sans tiret) mais avec un espace
Cela me renvoie cela :

Nom : RSC16.JPG
Affichages : 204
Taille : 24,0 Ko

C'est pas bon

edit : si on saisit 3 noms d'élèves associés à leur prénom respectif en les séparant par un espace, c'est le bug complet

klin89

**anasecu** · 17/03/2019, 10h30

Bonjour Klin89,

Envoyé par Klin89

si on saisit 3 noms d'élèves accompagnés de leur prénom respectif en les séparant par un espace, c'est le bug complet

Ah les espaces !!!
Bon ce n'est pas rédhibitoire, l'on peut avoir des prénoms composés avec peu de modifications :
Nom : kin89.jpg
Affichages : 191
Taille : 159,5 Ko

Nom : kin89.jpg
Affichages : 191
Taille : 159,5 Ko

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
94
95
96
97
98
99
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, 13).End(xlUp).Row, 10).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 Double, pkm As Double, nok As Boolean
    idr = 1: mfn = 0: tmf(0) = "=OU(": tmf(1) = "=OU("
    For ide = 2 To UBound(tbe)
        eec = "|*" & tbe(ide, 1) & "*": nec = 0: mfn = IIf(mfn, 0, 1): nok = False: nkm = 0: pkm = 0
        tmf(mfn) = tmf(mfn) & IIf(Len(tmf(mfn)) > 4, ";", "") & "$H2=""" & tbe(ide, 1) & """"
        For idd = 1 To UBound(tbd) - 1
            elm = Split(tbd(idd), "*")
            If elm(1) = "/" Then
                nec = nec + 1
                If InStr(eec, elm(2)) = 0 Then 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
                tbr(idr, 1) = Split(tbd(idd + 1) & "*", "*")(0) - Split(tbd(idd) & "*", "*")(0)
                tbr(idr, 2) = Split(tbd(idd) & "*", "*")(0) & " à " & Split(tbd(idd + 1) & "*", "*")(0)
                nkm = nkm + tbr(idr, 1)
                tbr(idr, 3) = tbe(ide, 1)
                tbr(idr, 4) = nec
                tbr(idr, 5) = Mid(eec, 3)
                tbr(idr, 7) = tbe(ide, 4)
                tbr(idr, 8) = IIf(nec = 1, 0.1, IIf(nec = 2, 0.23, 0.37))
                tbr(idr, 9) = tbr(idr, 1) * tbr(idr, 7) * (1 - tbr(idr, 8))
                pkm = pkm + tbr(idr, 9)
                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, 6) = nkm
                    tbr(idr - 1, 10) = 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)
        If Not IsNumeric(tbe(ide, 2)) Or tbe(ide, 2) = "" _
            Or Not IsNumeric(tbe(ide, 3)) Or tbe(ide, 3) = "" _
            Or tbe(ide, 3) <= tbe(ide, 2) Then
                MsgBox "Donnée PK incorrecte pour " & tbe(ide, 1): End
        End If
        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 CDbl(Left(tbd(ide), InStr(tbd(ide), "*") - 1)) > CDbl(Left(tbd(idd), InStr(tbd(idd), "*") - 1)) Then
                nom = tbd(ide): tbd(ide) = tbd(idd): tbd(idd) = nom
            End If
        Next idd
    Next ide
    ReDim tbr(1 To UBound(tbe) * 15, 1 To 10)
End Sub
Sub mfc()
    With ActiveSheet
        .Cells(2, 5).Activate
        With .Cells(2, 6).Resize(.Cells(Rows.Count, 13).End(xlUp).Row, 10)
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(1) & ")"
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ColorIndex = 44
            End With
            If Len(tmf(0)) > 4 Then
                .FormatConditions.Add Type:=xlExpression, Formula1:=tmf(0) & ")"
                With .FormatConditions(2).Interior
                    .PatternColorIndex = xlAutomatic
                    .ColorIndex = 39
                End With
            End If
        End With
    End With
End Sub

L'on aura peut-être fait le tour grâce à tes tests très approfondis.

Bon dimanche à tous

**Klin89** · 17/03/2019, 10h47

re anasecu

Tu as levé le syndrome "Jean / Jeanine"

Illustration :

Situation de départ :
Nom : RSC17.JPG
Affichages : 148
Taille : 11,5 Ko

Ce que je dois obtenir en colonne J :
Nom : RSC18.JPG
Affichages : 194
Taille : 28,8 Ko

Et ce que j'obtiens :

Nom : RSC19.JPG
Affichages : 197
Taille : 27,3 Ko

edit : pas tester ta nouvelle réponse

klin89

**Klin89** · 17/03/2019, 14h42

re anasecu,

Illustration du syndrome "Jean / Jeanine" avec un exemple simple

Situation de départ :
Nom : RSC20.JPG
Affichages : 154
Taille : 11,8 Ko

Ce que l'on doit obtenir colonne J :
Nom : RSC21.JPG
Affichages : 217
Taille : 22,4 Ko

Ce que l'on obtient :
Nom : RSC22.JPG
Affichages : 172
Taille : 30,1 Ko

Edit : dans le fichier du post #53#, tu n'as pas mis le nouveau code

klin89

**Klin89** · 17/03/2019, 19h47

re RyuAutodidacte,

J'ai testé ton code du post #39#
et j'ai un souci

Situation de départ :
Nom : RSC25.JPG
Affichages : 139
Taille : 11,7 Ko

et ce que j'obtiens
Nom : RSC26.JPG
Affichages : 139
Taille : 34,5 Ko

soit une ligne en trop

Je ne comprends pas que l'affectation ci-dessous me renvoie toujours nothing, je l'ai donc court-circuitée pour les tests.

tester sous Excel2003 chez moi

Code :

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

Set TB_Source = Application.InputBox(prompt:="Sélectionner une cellule", Title:="Choix du tableau source", Type:=8)

klin89

**RyuAutodidacte** · 17/03/2019, 19h54

Re Klin89,

Justement j'ai regardé les dernières news sur les test, et je testais aussi en parallèle.
j'en prends note et regarde cela

Edit : je suis embêté , car pour le même tableau, j'ai ce résultat chez moi, ci-dessous (Tab + Résultat) :

Noms des élèves	PK du ramassage	PK de la dépose	Tarif appliqué
Lacours	0	60	0,80 €
Lacourieux	30	80	0,80 €

Distance PK en Km	PK	Elève	Nb élèves	Elèves communs	Total Km/élève	Tarif	Abattement	Montant facturé	Montant total/élève
30	0 à 30	Lacours	1	Lacours		0,80 €	10%	21,6
30	30 à 60	Lacours	2	Lacours \| Lacourieux	60	0,80 €	23%	18,48	40,08
30	30 à 60	Lacourieux	2	Lacourieux \| Lacours		0,80 €	23%	18,48
20	60 à 80	Lacourieux	1	Lacourieux	50	0,80 €	10%	14,4	32,88

Par contre, j'ai bien un problème avec jean et jeanine …

Pour le InputBox je vais regarder aussi

Edit 2 : autant pour moi dans mon tableau Lacours à un s en trop par rapport à ton tableau

**mercatog** · 17/03/2019, 20h33

Bonsoir

Je continu de participer suite au post #22

Toujours l'abattement en I1:J3 (je suis contre que ça soit en dur dans le code)

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
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
94
95
96
97
98
99
100
Sub Test2()
Dim M As Long, N As Long, Cpt As Long, i As Long
Dim c As Range, v As Range
Dim Tmp As String
Dim D As Double, P As Double
Dim Tb()
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    M = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("M:Z").Clear
 
    For Each c In .Range("B2:B" & M)
        If c.Offset(, 1).Value <= c.Value Then
            MsgBox "Pk incohérents..."
            Exit Sub
        End If
    Next c
 
    .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
 
    For Each v In .Range("A2:A" & M)
        P = v.Offset(, 1).Value
        For Each c In .Range("P2: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
                i = i + 1
                ReDim Preserve Tb(1 To 8, 1 To i)
                Tb(1, i) = c.Offset(, -2).Value
                Tb(2, i) = P & "-" & P + Tb(1, i)
                P = P + Tb(1, i)
                Tb(3, i) = v.Value
                Tb(4, i) = c.Offset(, -1).Value
                Tmp = v.Value & Replace(c.Value, "| " & v.Value & " |", " |")
                Tmp = Left(Tmp, Len(Tmp) - 1)
                Tb(5, i) = Tmp
                Tb(7, i) = (1 - Barem(Tb(4, i))) * Tb(1, i) * v.Offset(, 3).Value
                .Range("T" & i + 1).Resize(, 8).Interior.Color = v.Interior.Color
            End If
        Next c
        Tb(6, i) = v.Offset(, 2).Value - v.Offset(, 1).Value
        Tb(8, i) = D
        D = 0
    Next v
 
    If i > 0 Then
        With .Range("T1").Resize(, 8)
            .Value = Array("Distance", "Pk", "Elève", "Nbre", "En commun", "Kms par élève", "Montant", "Total par élève")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
 
        With .Range("T2").Resize(i, 8)
            .Value = Application.Transpose(Tb)
            .EntireColumn.AutoFit
        End With
    End If
    .Range("M:S").EntireColumn.Delete
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 & ",$I$1:$I$3,$J$1:$J$3)")
End Function

**RyuAutodidacte** · 17/03/2019, 21h47

Bonsoir mercatog,

pour le code

je suis contre que ça soit en dur dans le code

C'est compréhensible et logique … mais rien n'empêche de le modifier par la suite, puisque nous ne connaissons pas la structure du fichier final …

**Klin89** · 18/03/2019, 00h34

Bonsoir mercatog

Magnifique cette façon de procéder

Il manque les colonnes tarif et abattement mais le résultat est là.
Pour chipoter, on pourrait dire que les espacements entre les barres verticales et les noms en colonne Q ne sont pas respecter

mais c'est tout bon sinon

J'ai changé ceci car le tiret pouvait me renvoyer des dates en colonne N

Code :

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