Optimisation itinéraires routiers avec étapes

**ZebreLoup** · 09/01/2012, 13h33

Si on avait une liste de points que l'on doit emprunter, en prenant à chaque fois le point le plus proche par lequel on n'est pas encore passé, on a la réponse. Donc pas besoin de faire des permutations ou autre.
J'ai peut-être aussi mal compris le problème, c'est possible.

Je dis une bêtise, avec un nombre de point obligatoire la solution n'est pas si triviale.

**philppe27** · 09/01/2012, 19h04

Bonsoir Qwaz,

Je suis le Candide dans cette discussion mais si je dis des âneries tant pis.
J'ai copier ton code avec l'analyse. En voyant le résultat, j'ai 2 remarques:

Lorsque l'on a 10 étapes, il est inutile de comparer la distance des 8 premières étapes avec

Excusez moi mauvaise manip.

Oui Qwaz et Sébastien les villes sont imposées, on doit obligatoirement y passer dans l'itinéraire. C'est par exemple, le voyageur de commerce qui doit visiter des clients ou le bus qui doit desservir impérativement des arrêts.
Donc 2 remarques:
Est-il nécessaire, dans un itinéraire de 10 étapes de comparer le nbre de km des 8 premières ? Y-a-t-il du temps à gagner ?
Si l'on trie, avant tout chose, les villes étapes en tenant compte de la distance la plus courte par rapport à l'étape précédente n'a-t-on pas plus de chance de tomber plus rapidement sur l'itinéraire le plus court et d'éliminer plus rapidement les itinéraires suivants ?

Merci pour vos réponses

**Qwazerty** · 09/01/2012, 19h16

Salut

Pour info, il est possible d'éditer un message que tu as posté. Y'a un bouton Editer qui apparaît sur ton message (tu peux aussi le supprimer)

Pour ta remarque concernant les 8 1er testes, au contraire, il faut les garder, ils permettent d'arrêter de tester un trajet dès que celui ci devient plus long que le meilleur trajet déjà trouvé.

Pour ce qui est du tri, je doute que le jeu en vaille la chandelle, en effet choisir l'itinéraire allant à la ville la plus proche ne garantira pas que celui-ci nous avantage par la suite.

++
Qwaz

Salut

Ca ne change rien (enfin sur un nombre réduit de villes), mais il y a ça qui n'allait pas

Code :

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

1
2
3
4
5
6
7
8
        'Si la distance dépasse la distance la plus courte déjà trouvée
        If MeilleurKm = 0 Or MeilleurKm > Distance Then
            PermuteVilles DicoKm, DicoVilleTmp, CStr(DicoVilleTmp.Keys(iVille)), VilleArrive, ParcoursTmp, DistanceTmp
        ElseIf MeilleurKm < Distance And MeilleurKm <> 0 Then
            'On retourne la meilleur combinaison
            PermuteVilles = MeilleurParcours & "$" & CStr(MeilleurKm) & " / " & NbrPermute
            Exit Function
        End If

Ça ne suffit pas, il continu de tester avec le chemin déjà trop long

++
Qwaz

SAlut

La nuit porte conseil.

Finalement cette partie du code est vraiment erroné, il ne faut surtout pas s’empêcher de tester les autre villes, puisque seul le parcours avec DicoVilleTmp.Keys(iVille) est devenu trop long (donc on ne va pas plus loin), mais pas le parcours "racine".
Donc il vaut mieux faire

Code :

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

1
2
3
4
        'Si la distance dépasse la distance la plus courte déjà trouvée
        If MeilleurKm = 0 Or MeilleurKm > Distance Then
            PermuteVilles DicoKm, DicoVilleTmp, CStr(DicoVilleTmp.Keys(iVille)), VilleArrive, ParcoursTmp, DistanceTmp
        End If

Par contre, peut-être une piste d'amélioration

-Au début on se garde la distance la plus courte entre 2 villes (DistanceCourte), pas sur l’ensemble des villes contenues dans le tableau de gauche, mais uniquement les 5, 7, 12, 15... villes choisies pour le parcours. Lors du teste pour savoir si un début de parcours ne dépasserait pas déjà la meilleur distance trouvée, on rajoute à la distance de parcours autant de fois DistanceCourte qu'il reste de trajet à faire.
exemple
Brionne¤Marseille¤Mulhouse
Si on dit qu'il nous reste 3 trajets pour arrivé à la ville d'arrivé, on fera donc potentiellement 3*DistanceCourte de trajet au minimum pour arrivé à destination.
Inconvénient:Si DistanceCourte est très courte vis à vis des autre distance, on aura aucune amélioration

-On peut amélioré encore un peu en utilisant un tableau de distanceCourte
Etape 1, on trie les distances par ordre croissant
Dist1
Dist2
Dist3
Dist4
...
Ensuite on dit
DistA=Dist1 (plus qu'une ville à parcourir)
DistB=DistA+Dist2 (reste 2 ville à parcourir)
DistC=DistB+Dist3 (reste 3 ville)
...
Du coup lors du teste vis à vis de la meilleur distance, au lieu de dire 3 fois le trajet le plus court, on utiliser la distance A, B, C... qui correspond au nombre d ville restant à parcourir.
Avantage, on gomme un peu l'inconvénient de la méthode précédente.

En faisant cela, il sera peut-être possible d'abandonner plus tôt des itinéraires qui seront trop groumant à l'arrivé.

++
Qwaz

**ZebreLoup** · 10/01/2012, 09h27

Bon, désolé à tous les deux, j'avais mal lu le premier message, j'ai tout de suite cru que ça correspondait à un truc que j'avais fait la semaine dernière du coup...
Sorry

Du coup, je vais voir si je peux aider sur le vrai problème mais j'ai l'impression que Qwazerty a déjà plus ou moins tout résolu

**Qwazerty** · 11/01/2012, 20h04

Salut

@ZebreLoup: Il me semblait bien

ça m'arrive aussi de vouloir réutiliser

Voila la dernière mouture

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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
Sub Villes()
 
Dim TabVilleEtape
Dim TheCell As Range
Dim DicoDistance As New Dictionary
Dim DicoVille As New Dictionary
Dim LastRow As Integer
Dim x As Integer, y As Integer
Dim TabRetour
 
 
 
    'On place les km dans le dico (plus rapide que d'aller chercher dans le tableau excel
    With ThisWorkbook.Sheets("Données")
        LastRow = .Range("B28").End(xlUp).Row
        TabVilleEtape = .Range("B7", .Cells(LastRow, "B").Offset(0, LastRow - 7)).Value
    End With
 
    'On boucle dans le tableau
    For x = 2 To LastRow - 6
        For y = 2 To LastRow - 6
            DicoDistance.Add TabVilleEtape(1, x) & "¤" & TabVilleEtape(1, y), CDbl(TabVilleEtape(x, y))
        Next
    Next
 
    'On récupère la liste des villes étapes
    With ThisWorkbook.Sheets("Données")
        For Each TheCell In .Range("X10", .Range("X29").End(xlUp))
            DicoVille.Add TheCell.Value, ""
        Next
    End With
 
 
    'On appelle PermuteVilles
    With ThisWorkbook.Sheets("Données")
        TabRetour = PermuteVilles(DicoDistance, DicoVille, .Range("X8"), .Range("X9"))
 
        'On place le meilleur parcours dans le tabelau excel
        'On vide
        .Range("Y8:Y28").ClearContents
        'On inscrit les km
        .Range("AA7").Value = Split(TabRetour, "$")(1)
        'On ne conserve que le parcours
        TabRetour = Split(TabRetour, "$")(0)
        'On permute la chaine en tableau
        TabRetour = Split(TabRetour, "¤")
        'On place le tableau
        .Range("Y8").Resize(UBound(TabRetour) + 1).Value = WorksheetFunction.Transpose(TabRetour)
 
    End With
 
 
End Sub
Function PermuteVilles(DicoKm As Dictionary, DicoVille As Dictionary, VilleDepart As String, VilleArrive, Optional aParcours As String = "<vide>", Optional aDistance As Double)
Dim DicoVilleTmp As New Dictionary
Dim iVille As Integer, iVilleT As Integer, iPos As Integer
Dim tmpDist As Double
Static MeilleurKm As Double
Static MeilleurParcours As String
Static NbrPermute As Long
Dim ParcoursEnCours As String
Dim Distance As Double
Dim MustExit As Boolean
 
Dim ParcoursTmp As String
Dim DistanceTmp As Double
Dim DistanceSuppose As Double
Dim DicoTrajetRestant As New Dictionary
 
    'On prolonge le parcours existant
    If aParcours <> "<vide>" Then
        ParcoursEnCours = aParcours
        Distance = aDistance
    Else
        'On initialise les variables "Meilleur", les variables static sont conservées, même aprés une analyse complete
        MeilleurKm = 0
        MeilleurParcours = ""
        'Et On début le parcours
        ParcoursEnCours = VilleDepart
        NbrPermute = 0
    End If
 
    'On clone le dico, moins la ville de départ
    For iVille = 0 To DicoVille.Count - 1
        If DicoVille.Keys(iVille) <> VilleDepart Then
            DicoVilleTmp.Add DicoVille.Keys(iVille), ""
        End If
        For iVilleT = iVille + 1 To DicoVille.Count - 1
            tmpDist = DicoKm(VilleDepart & "¤" & DicoVille.Keys(iVilleT))
            'On boucle sur le contenu du dico
            For iPos = 0 To DicoTrajetRestant.Count - 1
                If tmpDist < DicoTrajetRestant.Items(iPos) Then
                    'On l'ajoute devant
                    InsertDico DicoTrajetRestant, iPos, DicoVille.Keys(iVille) & "¤" & DicoVille.Keys(iVilleT), tmpDist
                    GoTo Suite
                End If
            Next
            'Si l'execution du code passe par ici, la valeur doit être ajoutée à la suite du dico
            DicoTrajetRestant.Add DicoVille.Keys(iVille) & "¤" & DicoVille.Keys(iVilleT), tmpDist
Suite:
        Next
    Next
 
    'On calcule les km de trajet max en fonction du nombre de villes restant à visiter
    If DicoTrajetRestant.Count > 0 Then DicoTrajetRestant.Key(DicoTrajetRestant.Keys(0)) = 1
    For iPos = 1 To DicoTrajetRestant.Count - 1
        DicoTrajetRestant.Key(DicoTrajetRestant.Keys(iPos)) = iPos + 1
        DicoTrajetRestant(iPos + 1) = DicoTrajetRestant.Items(iPos) + DicoTrajetRestant.Items(iPos - 1)
    Next
    'Pour éviter les erreurs par la suite
    DicoTrajetRestant.Add 0, 0
 
    'On calcule les distances entre villeDepart et toutes les villes étapes
    For iVille = 0 To DicoVilleTmp.Count - 1
        NbrPermute = NbrPermute + 1
        'On ajoute la ville au parcours et distance temporaires, pour conserver les bon contenu dans ParcoursEnCours et Distance
        'Comme ça, après l'appel récursif, ParcoursEnCours et Distance contiennent les bonne valeur pour accépter le teste d'une nouvelle ville
        If ParcoursEnCours <> "" Then ParcoursTmp = ParcoursEnCours & "¤"
        ParcoursTmp = ParcoursTmp & DicoVilleTmp.Keys(iVille)
        DistanceTmp = Distance + DicoKm(VilleDepart & "¤" & DicoVilleTmp.Keys(iVille))
        'On ajoute à la distance, le nombre de km minimum qu'il reste à parcourir pour faire le nombre de trajet au total
        DistanceSuppose = DistanceTmp + DicoTrajetRestant(DicoVilleTmp.Count - 1)
 
                'On note dans le tableau Excel (analyse)
                With ThisWorkbook.Sheets("Données")
                    With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                        .Value = ParcoursTmp
                        .Offset(0, 1) = DistanceTmp
                        .Offset(0, 2) = MeilleurKm
                        .Offset(0, 3) = DistanceSuppose
                    End With
                End With
 
        'Si la distance dépasse la distance la plus courte déjà trouvée, en tenant compte du nombre de trajet qu'il reste à faire
        If MeilleurKm = 0 Or MeilleurKm > DistanceSuppose Then
            PermuteVilles DicoKm, DicoVilleTmp, CStr(DicoVilleTmp.Keys(iVille)), VilleArrive, ParcoursTmp, DistanceTmp
        End If
    Next
 
    If DicoVilleTmp.Count = 0 Then
        'On boucle le trajet avec la ville d'arrivé
        If ParcoursEnCours <> "" Then ParcoursEnCours = ParcoursEnCours & "¤"
        ParcoursEnCours = ParcoursEnCours & VilleArrive
        Distance = Distance + DicoKm(VilleDepart & "¤" & VilleArrive)
        'On verifie les km
        If MeilleurKm = 0 Or MeilleurKm > Distance Then
            MeilleurKm = Distance
            MeilleurParcours = ParcoursEnCours
        End If
 
                'On note dans le tableau Excel (analyse)
                With ThisWorkbook.Sheets("Données")
                    With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                        .Value = ParcoursEnCours 'ParcoursTmp
                        .Offset(0, 1) = Distance 'Tmp
                        .Offset(0, 2) = MeilleurKm
                        '.Offset(0, 3) = DistanceSuppose
                    End With
                End With
 
        'On vide les variables pour annalyser le prochain parcours
        Distance = 0
        ParcoursEnCours = ""
    End If
 
    'On retourne la meilleur combinaison
    PermuteVilles = MeilleurParcours & "$" & CStr(MeilleurKm) & " / " & NbrPermute
 
End Function
 
 
Sub InsertDico(ByRef aDico As Dictionary, AvantItem As Integer, aKey, aItem)
Dim iPos As Integer
Dim tmpKey, tmpItem
    'On place les donnée en fin de dico pour créer une ligne
    aDico.Add aKey, aItem
 
    'On boucle à partie du bas
    For iPos = aDico.Count - 1 To AvantItem + 1 Step -1
        'On mémorise les valeurs
        tmpKey = aDico.Keys(iPos - 1)
        tmpItem = aDico.Items(iPos - 1)
 
        'On modifie le contenu de key pour éviter les doublons le temps de la copie
        aDico.Key(aDico.Keys(iPos - 1)) = tmpKey & "¤¤"
 
        'On décale chaque valeur vers le bas
        aDico.Key(aDico.Keys(iPos)) = tmpKey
        aDico(aDico.Keys(iPos)) = tmpItem
    Next
 
    'On place ensuite les nouvelle valeur à leur place d'insertion
    aDico.Key(aDico.Keys(AvantItem)) = aKey
    aDico(aDico.Keys(AvantItem)) = aItem
 
End Sub

Pour faire des essais avec plus de villes, il vaudrait mieux supprimer les passages liés à l'inscription des données sur la page Excel, ils ralentiraient beaucoup trop la routine.

Je joins également un fichier pour expliquer l'analyse des données qui s'inscrive justement dans la feuille Excel. dans l'exemple donnée, on teste 14 parcours viables (quand je dis viable, c'est qu'il permettent de faire la boucle complète) au lieu des 24 prévus.
J'ai peur de ne pas pouvoir améliorer plus la routine.... j'ai peut-être manquer une simplification ou 2 à force de modifier le code, mais ne compte pas réduire de moitié le temps de traitement :p

++
Qwaz

**philppe27** · 11/01/2012, 20h25

Bonsoir à tous,
Quaz avec la dernière modif pas de soucis le résultat est bien celui recherché.
Par contre, l'optimisation maintenant c'est le temps.
J'ai fait quelques tests et je m'aperçois que plus l'ordre de départ dans la colonne X est proche du résultat final attendu moins le temps de traitement est élevé. J'obtiens des écarts de 3 à 25% avec 10 étapes intermédiaires, ce qui n'est pas négligeable
Je suis, donc, reparti sur un tri en début de traitement de la colonne X, ci dessous le code qui va certainement vous horrifier (à mettre en début de programme)

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
fin1 = ThisWorkbook.Sheets("Données").Range("X65000").End(xlUp).Row
 
    If fin1 > 11 Then
        ' tri pour obtenir la ville la plus proche du point de départ
        ThisWorkbook.Sheets("Données").Range("Y8:Y28").ClearContents
        ThisWorkbook.Sheets("Données").Range("Y10:Y" & fin1 & "").FormulaR1C1 = _
            "=INDEX(donnees,MATCH(RefDep,depar,0),MATCH(RC[-1],arriv,0))"
        ThisWorkbook.Sheets("Données").Range("Y10:Y" & fin1 & "").Value = ThisWorkbook.Sheets("Données").Range("Y10:Y" & fin1 & "").Value
        ThisWorkbook.Worksheets("Données").Sort.SortFields.Clear
        ThisWorkbook.Worksheets("Données").Sort.SortFields.Add Key:=Range("Y10:Y" & fin1 & "" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ThisWorkbook.Worksheets("Données").Sort
            .SetRange Range("X10:Y" & fin1 & "")
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        fin2 = 11
        While fin1 >= fin2 + 1 'boucle pour que l'étape suivante soit la plus proche de l'étape précédente
            ThisWorkbook.Sheets("Données").Range("Y8:Y28").ClearContents
            ThisWorkbook.Sheets("Données").Range("Y" & fin2 & ":Y" & fin1 & "").FormulaR1C1 = _
                "=INDEX(donnees,MATCH(R" & fin2 - 1 & "C[-1],depar,0),MATCH(RC[-1],arriv,0))"
            ThisWorkbook.Sheets("Données").Range("Y" & fin2 & ":Y" & fin1 & "").Value = ThisWorkbook.Sheets("Données").Range("Y" & fin2 & ":Y" & fin1 & "").Value
            ThisWorkbook.Worksheets("Données").Sort.SortFields.Clear
            ThisWorkbook.Worksheets("Données").Sort.SortFields.Add Key:=Range("Y" & fin2 & ":Y" & fin1 & "" _
                ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With ThisWorkbook.Worksheets("Données").Sort
                .SetRange Range("X" & fin2 & ":Y" & fin1 & "")
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            fin2 = fin2 + 1
        Wend
        If fin1 - 9 > 6 Then 'si au moins 6 étapes les 3 dernières ordonnancées par rapport à la ville d'arrivée
            fin2 = fin1
            ThisWorkbook.Sheets("Données").Range("Y" & fin1 - 2 & ":Y" & fin2 & "").FormulaR1C1 = _
                "=INDEX(donnees,MATCH(RC[-1],depar,0),MATCH(RefArriv,arriv,0))"
            ThisWorkbook.Sheets("Données").Range("Y" & fin1 - 2 & ":Y" & fin2 & "").Value = ThisWorkbook.Sheets("Données").Range("Y" & fin1 - 2 & ":Y" & fin2 & "").Value
            ThisWorkbook.Worksheets("Données").Sort.SortFields.Clear
            ThisWorkbook.Worksheets("Données").Sort.SortFields.Add Key:=Range("Y" & fin1 - 2 & ":Y" & fin2 & "" _
                ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            With ThisWorkbook.Worksheets("Données").Sort
                .SetRange Range("X" & fin1 - 2 & ":Y" & fin2 & "")
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            fin2 = fin2 - 1
            ThisWorkbook.Sheets("Données").Range("Y" & fin1 - 2 & ":Y" & fin2 & "").FormulaR1C1 = _
                "=INDEX(donnees,MATCH(RC[-1],depar,0),MATCH(R" & fin2 + 1 & "C[-1],arriv,0))"
            ThisWorkbook.Sheets("Données").Range("Y" & fin1 - 2 & ":Y" & fin2 & "").Value = ThisWorkbook.Sheets("Données").Range("Y" & fin1 - 2 & ":Y" & fin2 & "").Value
            ThisWorkbook.Worksheets("Données").Sort.SortFields.Clear
            ThisWorkbook.Worksheets("Données").Sort.SortFields.Add Key:=Range("Y" & fin1 - 2 & ":Y" & fin2 & "" _
                ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            With ThisWorkbook.Worksheets("Données").Sort
                .SetRange Range("X" & fin1 - 2 & ":Y" & fin2 & "")
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            fin2 = fin2 - 1
        End If
        ThisWorkbook.Sheets("Données").Range("Y8:Y28").ClearContents
    Else
        Exit Sub
    End If

Le principe est que l'étape suivante soit la plus proche de l'étape précédente.
Je reprends les 3 dernières étapes et je les ordonnance, selon le même principe, par rapport à l'arrivée imposée.
Les résultats sont très intéressants et j'en note un qui me semble important. En effet, l'écart les plus importants que l'on peut constater entre le tri que je décris plus haut et le résultat optimisé final (en km), s'observe lorsque l'on a sur un parcours important (ex: 10 étapes +départ +arrivée = + de 3000km) 3 ou 4 villes qui se trouve assez proche du point de départ et donc d'arrivée. Mais lorsque l'on observe le résultat optimisée final on s'aperçoit que le résultat final optimisé est très proche du résultat trié comme décrit plus haut (-0.5% du parcours total).
Je pense donc qu'il n'y a pas grande utilité à sélectionner des parcours qui sont inférieurs de 2% à celui retenu précédemment. Si cela permet d'avoir un gain de temps de traitement, bien sûr ...
Merci de me dire ce que vous en pensez ?
Cordialement

Bonsoir Qwaz,
Nos derniers messages se sont croisés. Je regarde le tien et je reviens vers toi

**Qwazerty** · 11/01/2012, 20h59

Salut

Si ça ne te dérange pas je préfère le tutoiement mais si besoin je m'adapterai.

Pour le tri des données, je suis assez septique, imaginons les villes suivantes

Paris, Brest, Tours, Toulouse.

On par de Paris, le plus prés de Paris -> Tours
Ensuite le plus proche Tours -> Brest
Reste donc Brest -> Toulouse

Pourtant le trajet le plus logique serait Paris, Brest, Tours, Toulouse. Hors en triant pas distance on fini par s'éloigner Toulouse.

Si on ajoute Reinne en plus, on continue de s'éloigné en allant de Brest à Reinne.

[Edit]
Si tu tiens à trier les villes, il serait certainement intéressant de le faire une fois le dicoKM renseigné, car celui-ci contenant toutes les distance, il est plus facile d'organiser les villes selon ton besoin.
[/Edit]
++
Qwaz

**philppe27** · 11/01/2012, 22h21

Qwaz,

Je viens de tester ton dernier programme. Il y a un problème le résultat obtenu n'est pas systématiquement le résultat optimisé.
(ex: départ Brionne, arrivée Brionne, Etapes dans l'ordre colonne X: Marseille, Mulhouse, Paris, Toulouse, Brest, Rennes, Bordeaux, Lilles, Nanterre, Nancy) --> résultat faux et 1,18 mn de traitement. Par contre lorsque je met dans la colonne X les étapes dans l'ordre optimisé soit (Nanterre, Paris, Lille, Nancy, Mulhouse, Marseille, Toulouse, Bordeaux, Brest, Rennes) --> résultat ok et 0,31 mn de traitement alors qu'avec le programme précédent j'obtenais 0,51 mn.
Il doit y avoir une erreur dans une boucle.
Lorsque je fais ces calculs je neutralise l'analyse.
Concernant, l'exemple que tu me donnes, il y a un écart de moins de 2% entre les 2 trajets donc non significatif pour moi. L'idéal serait d'avoir en paramètre modifiable une approximation de résultat et de continuer sur le principe du tri au départ.
Merci de ton aide

**mercatog** · 12/01/2012, 00h06

Bonsoir à tous.
Intéresse par le sujet, je me suis donnée du temps pour étudier différents ouvrages sur l'optimisation du trajet.
Plusieurs algorithmes permettent de donner un solution approché à l'optimum théorique vu les ressources nécessaires pour scruter toutes les combinaisons possibles.

Ci-joint un lien proche et intéressant http://www.developpez.net/forums/d85...-temps-trajet/

Ci-joint une contribution de solution tiré d'un algorithme 2-opt amélioré testé sur le fichier (avec la seule contrainte, ville de départ=ville d'arrivé et nombre de ville >4)
Le cas général pourra être adapté facilement

Le code comme dit auparavant permet de trouver les optimums locaux, de ce fait, il ne donne pas catégoriquement l'optimum global.
J'ai insérer une constante NbEssais pour essayer de recommencer la recherche en espérant trouver cet optimum.

La cellule AA9 permet de stocker l'optimum trouvé. Pour chaque problème d'optimisation, elle devra être vide

La ville de départ et d'arrivée est en cellule X8

Pour NbEssais=100! avec 20 villes, le résultat est trouvé en moins de 3s.
Pour un nombre de villes moindres, NbEssais=6 permet d'arriver au résultat.

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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
Option Explicit
 
Dim Tb() As String                               'Tb tableau à ordonner par échange de villes dans la pile
Dim Matrice                                      'Matrice des distances
Dim Nb As Byte                                   'Nombre de villes +1(Ville de départ=Ville d'arrivée)
 
'Diastance entre les villes i et j
Private Function Distance(ByVal i As Byte, j As Byte) As Double
Dim a As Byte, b As Byte
 
For a = 1 To UBound(Matrice, 1)
    If Matrice(1, a) = Tb(i) Then Exit For
Next a
For b = 1 To UBound(Matrice, 1)
    If Matrice(b, 1) = Tb(j) Then Exit For
Next b
Distance = Matrice(b, a)
End Function
 
'Permute les villes i et j
Private Sub PERMUTE(ByVal i As Byte, j As Byte)
Dim Tmp As String
 
Tmp = Tb(i)
Tb(i) = Tb(j)
Tb(j) = Tmp
End Sub
 
'Renverse le parcours entre les villes i et j
Private Sub RENVERSE(ByVal i As Byte, ByVal j As Byte)
Dim a As Byte, b As Byte
 
a = Application.Min(i, j)
b = Application.Max(i, j)
Do While a < b
    PERMUTE a, b
    a = a + 1
    b = b - 1
Loop
End Sub
 
'Insère la ville i entre les villes j et j+1
Private Sub INSERT(ByVal i As Byte, ByVal j As Byte)
Dim Tmp As String
 
Tmp = Tb(i)
Do While i < j
    Tb(i) = Tb(i + 1)
    i = i + 1
Loop
Tb(j) = Tmp
End Sub
 
'Insère la ville j entre les villes i et i+1
Private Sub INSERT_INV(ByVal i As Byte, ByVal j As Byte)
Dim Tmp As String
 
Tmp = Tb(j)
Do While j > i
    Tb(j) = Tb(j - 1)
    j = j - 1
Loop
Tb(i) = Tmp
End Sub
 
'Différence de la distance du parcours si on renversait les villes i et j
Private Function DIFF_2OPT(ByVal i As Byte, j As Byte) As Double
Dim d As Double
 
d = Distance(i - 1, j) - Distance(i - 1, i)
If j < Nb Then d = d + Distance(i, j + 1) - Distance(j, j + 1)
DIFF_2OPT = d
End Function
 
'Différence de la distance du parcours si on insère la ville i entre j et j+1
Private Function DIFF_INSERT(ByVal i As Byte, j As Byte)
Dim d As Double
 
d = Distance(i, j) + Distance(i - 1, i + 1) - Distance(i - 1, i) - Distance(i, i + 1)
If j < Nb Then d = d + Distance(i, j + 1) - Distance(j, j + 1)
DIFF_INSERT = d
End Function
 
'Différence de la distance du parcours si on insère la ville j entre i et i+1
Private Function DIFF_INSERT_INV(ByVal i As Byte, j As Byte)
Dim d As Double
 
d = Distance(i, j) + Distance(i - 1, j) - Distance(i - 1, i) - Distance(j - 1, j)
If j < Nb Then d = d + Distance(j - 1, j + 1) - Distance(j, j + 1)
DIFF_INSERT_INV = d
End Function
 
'Bouclage pour insertion et inversion jusqu'à optimum
Private Sub CALCUL_PARCOURS_2OPT_INSERT()
Dim i As Byte, j As Byte
Dim Modif As Boolean
 
Do
    Modif = False
    For i = 2 To Nb - 2
        For j = i + 1 To Nb - 1
            If DIFF_2OPT(i, j) < 0 Then
                RENVERSE i, j
                Modif = True
            End If
        Next j
    Next i
 
    For i = 2 To Nb - 3
        For j = i + 2 To Nb - 1
            If DIFF_INSERT(i, j) < 0 Then
                INSERT i, j
                Modif = True
            ElseIf DIFF_INSERT_INV(i, j) < 0 Then
                INSERT_INV i, j
                Modif = True
            End If
        Next j
    Next i
Loop While Not Modif
End Sub
 
'Initialise un parcours au hasard
Private Sub HASARD()
Dim i As Byte, j As Byte, a As Byte, b As Byte
Dim Brut As Variant
 
With Worksheets("Données")
    Brut = .Range("X8", .Range("X29").End(xlUp))
    Matrice = .Range("B7:V27").Value
 
    Nb = UBound(Brut, 1) + 1
    ReDim Tb(1 To Nb)
    For i = 1 To Nb
        j = IIf(i = Nb, 1, i)
        Tb(i) = Brut(j, 1)
    Next i
 
    For i = 2 To Nb - 1
        Randomize i
        a = Int((Nb - 2) * Rnd() + 2)
        Randomize Nb - i
        b = Int((Nb - 2) * Rnd() + 2)
        PERMUTE a, b
    Next i
End With
End Sub
 
'Lancement
Public Sub LANCEMENT()
Dim i As Byte, k As Byte
Dim S As Double, So As Double
Const NbEssais As Byte = 100                       'nombre de boucles pour améliorer l'optimum local
 
For k = 1 To NbEssais
    S = 0
    HASARD
    If Nb > 4 Then
        CALCUL_PARCOURS_2OPT_INSERT
        For i = 2 To Nb
            S = S + Distance(i - 1, i)
        Next i
        With Worksheets("Données")
            So = Val(.Range("AA9").Value)
            If S < So Or So = 0 Then
                .Range("Y8:Y28").ClearContents
                For i = 1 To Nb
                    .Range("Y" & i + 7).Value = Tb(i)
                Next i
                .Range("AA9").Value = S
            End If
        End With
    Else
        MsgBox "Nombre de villes insuffisant (minium 4 villes)"
        Exit Sub
    End If
    Erase Matrice
Next k
Erase Tb
MsgBox "Traitement Terminé"
End Sub

Code légèrement commenté

**Qwazerty** · 12/01/2012, 07h29

SAlut

Je place malgré tout la modif, qui d’ailleurs allonge le temps de traitement, mais ce sera négligeable sur un plus grand nombre de ville.

Pour ce qui est du 2%, je part au taff, mais je pense que le plus simple est de rajouter les 2% au moment du teste Meilleurkm + 2% < Distancesuppose

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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
Sub Villes()
 
Dim TabVilleEtape
Dim TheCell As Range
Dim DicoDistance As New Dictionary
Dim DicoVille As New Dictionary
Dim LastRow As Integer
Dim x As Integer, y As Integer, iPos As Integer
Dim TabRetour
Dim tmpDist As Double, tmpParcours As String
 
 
    'On place les km dans le dico (plus rapide que d'aller chercher dans le tableau excel
    With ThisWorkbook.Sheets("Données")
        LastRow = .Range("B28").End(xlUp).Row
        TabVilleEtape = .Range("B7", .Cells(LastRow, "B").Offset(0, LastRow - 7)).Value
    End With
 
 
    'On boucle dans le tableau et on le classe par longueur de trajet
    For x = 2 To LastRow - 6
        For y = 2 To LastRow - 6
            tmpDist = CDbl(TabVilleEtape(x, y))
            tmpParcours = TabVilleEtape(1, x) & "¤" & TabVilleEtape(1, y)
            For iPos = 0 To DicoDistance.Count - 1
                If tmpDist < DicoDistance.Items(iPos) Then
                    'On le place devant
                    InsertDico DicoDistance, iPos, tmpParcours, tmpDist
                    GoTo suite
                End If
            Next
            DicoDistance.Add tmpParcours, tmpDist
suite:
        Next
    Next
 
    'On récupère la liste des villes étapes
    With ThisWorkbook.Sheets("Données")
        For Each TheCell In .Range("X10", .Range("X29").End(xlUp))
            DicoVille.Add TheCell.Value, ""
        Next
    End With
 
 
    'On appelle PermuteVilles
    With ThisWorkbook.Sheets("Données")
        TabRetour = PermuteVilles(DicoDistance, DicoVille, .Range("X8"), .Range("X9"))
 
        'On place le meilleur parcours dans le tabelau excel
        'On vide
        .Range("Y8:Y28").ClearContents
        'On inscrit les km
        .Range("AA7").Value = Split(TabRetour, "$")(1)
        'On ne conserve que le parcours
        TabRetour = Split(TabRetour, "$")(0)
        'On permute la chaine en tableau
        TabRetour = Split(TabRetour, "¤")
        'On place le tableau
        .Range("Y8").Resize(UBound(TabRetour) + 1).Value = WorksheetFunction.Transpose(TabRetour)
 
    End With
 
 
End Sub
Function PermuteVilles(DicoKm As Dictionary, DicoVille As Dictionary, VilleDepart As String, VilleArrive, Optional aParcours As String = "<vide>", Optional aDistance As Double)
Dim DicoVilleTmp As New Dictionary
Dim iVille As Integer, iVilleT As Integer, iPos As Integer
Dim tmpDist As Double, tmpParcours As String
Static MeilleurKm As Double
Static MeilleurParcours As String
Static NbrPermute As Long
Dim ParcoursEnCours As String
Dim Distance As Double
Dim MustExit As Boolean
 
Dim ParcoursTmp As String
Dim DistanceTmp As Double
Dim DistanceSuppose As Double
Dim DicoTrajetRestant As New Dictionary
 
    'On prolonge le parcours existant
    If aParcours <> "<vide>" Then
        ParcoursEnCours = aParcours
        Distance = aDistance
    Else
        'On initialise les variables "Meilleur", les variables static sont conservées, même aprés une analyse complete
        MeilleurKm = 0
        MeilleurParcours = ""
        'Et On début le parcours
        ParcoursEnCours = VilleDepart
        NbrPermute = 0
    End If
 
    'On clone le dico, moins la ville de départ
    For iVille = 0 To DicoVille.Count - 1
        If DicoVille.Keys(iVille) <> VilleDepart Then
            DicoVilleTmp.Add DicoVille.Keys(iVille), ""
        End If
        For iVilleT = iVille + 1 To DicoVille.Count - 1
            tmpDist = DicoKm(VilleDepart & "¤" & DicoVille.Keys(iVilleT))
            tmpParcours = DicoVille.Keys(iVille) & "¤" & DicoVille.Keys(iVilleT)
            'On boucle sur le contenu du dico
            For iPos = 0 To DicoTrajetRestant.Count - 1
                If tmpDist < DicoTrajetRestant.Items(iPos) Then
                    'On l'ajoute devant
                    InsertDico DicoTrajetRestant, iPos, tmpParcours, tmpDist
                    GoTo suite
                End If
            Next
            'Si l'execution du code passe par ici, la valeur doit être ajoutée à la suite du dico
            DicoTrajetRestant.Add tmpParcours, tmpDist
suite:
        Next
    Next
 
    'On calcule les km de trajet max en fonction du nombre de villes restant à visiter
    If DicoTrajetRestant.Count > 0 Then DicoTrajetRestant.Key(DicoTrajetRestant.Keys(0)) = 1
    For iPos = 1 To DicoTrajetRestant.Count - 1
        DicoTrajetRestant.Key(DicoTrajetRestant.Keys(iPos)) = iPos + 1
        DicoTrajetRestant(iPos + 1) = DicoTrajetRestant.Items(iPos) + DicoTrajetRestant.Items(iPos - 1)
    Next
    'Pour éviter les erreurs par la suite
    DicoTrajetRestant.Add 0, 0
 
    'On calcule les distances entre villeDepart et toutes les villes étapes
    For iVille = 0 To DicoVilleTmp.Count - 1
        NbrPermute = NbrPermute + 1
        'On ajoute la ville au parcours et distance temporaires, pour conserver les bon contenu dans ParcoursEnCours et Distance
        'Comme ça, après l'appel récursif, ParcoursEnCours et Distance contiennent les bonne valeur pour accépter le teste d'une nouvelle ville
        If ParcoursEnCours <> "" Then ParcoursTmp = ParcoursEnCours & "¤"
        ParcoursTmp = ParcoursTmp & DicoVilleTmp.Keys(iVille)
        DistanceTmp = Distance + DicoKm(VilleDepart & "¤" & DicoVilleTmp.Keys(iVille))
        'On ajoute à la distance, le nombre de km minimum qu'il reste à parcourir pour faire le nombre de trajet au total
        DistanceSuppose = DistanceTmp + DicoTrajetRestant(DicoVilleTmp.Count - 1)
 
                'On note dans le tableau Excel (analyse)
                With ThisWorkbook.Sheets("Données")
                    With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                        .Value = ParcoursTmp
                        .Offset(0, 1) = DistanceTmp
                        .Offset(0, 2) = MeilleurKm
                        .Offset(0, 3) = DistanceSuppose
                    End With
                End With
 
        'Si la distance dépasse la distance la plus courte déjà trouvée, en tenant compte du nombre de trajet qu'il reste à faire
        If MeilleurKm = 0 Or MeilleurKm > DistanceSuppose Then
            PermuteVilles DicoKm, DicoVilleTmp, CStr(DicoVilleTmp.Keys(iVille)), VilleArrive, ParcoursTmp, DistanceTmp
        End If
    Next
 
    If DicoVilleTmp.Count = 0 Then
        'On boucle le trajet avec la ville d'arrivé
        If ParcoursEnCours <> "" Then ParcoursEnCours = ParcoursEnCours & "¤"
        ParcoursEnCours = ParcoursEnCours & VilleArrive
        Distance = Distance + DicoKm(VilleDepart & "¤" & VilleArrive)
        'On verifie les km
        If MeilleurKm = 0 Or MeilleurKm > Distance Then
            MeilleurKm = Distance
            MeilleurParcours = ParcoursEnCours
        End If
 
                'On note dans le tableau Excel (analyse)
                With ThisWorkbook.Sheets("Données")
                    With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                        .Value = ParcoursEnCours 'ParcoursTmp
                        .Offset(0, 1) = Distance 'Tmp
                        .Offset(0, 2) = MeilleurKm
                        '.Offset(0, 3) = DistanceSuppose
                    End With
                End With
 
        'On vide les variables pour annalyser le prochain parcours
        Distance = 0
        ParcoursEnCours = ""
    End If
 
    'On retourne la meilleur combinaison
    PermuteVilles = MeilleurParcours & "$" & CStr(MeilleurKm) & " / " & NbrPermute
 
End Function
 
 
Sub InsertDico(ByRef aDico As Dictionary, AvantItem As Integer, aKey, aItem)
Dim iPos As Integer
Dim tmpKey, tmpItem
    'On place les donnée en fin de dico pour créer une ligne
    aDico.Add aKey, aItem
 
    'On boucle à partie du bas
    For iPos = aDico.Count - 1 To AvantItem + 1 Step -1
        'On mémorise les valeurs
        tmpKey = aDico.Keys(iPos - 1)
        tmpItem = aDico.Items(iPos - 1)
 
        'On modifie le contenu de key pour éviter les doublons le temps de la copie
        aDico.Key(aDico.Keys(iPos - 1)) = tmpKey & "¤¤"
 
        'On décale chaque valeur vers le bas
        aDico.Key(aDico.Keys(iPos)) = tmpKey
        aDico(aDico.Keys(iPos)) = tmpItem
    Next
 
    'On place ensuite les nouvelle valeur à leur place d'insertion
    aDico.Key(aDico.Keys(AvantItem)) = aKey
    aDico(aDico.Keys(AvantItem)) = aItem
 
End Sub

J'essaierai la solution de Mercatog ce soir ... sniff voila ce que c'est de pas faire de recherche

++
Qwaz

**philppe27** · 12/01/2012, 19h36

Bonsoir Qwaz et Mercatog,

J'ai testé le dernier programme mais j'ai le même problème que pour la 1ère version de la v2. Nbre de km +10 % par rapport au parcours optimisé sauf quand je fais le tri préalable. Pour l'instant la v1 était plus rapide et pus fiable.
Je regarde le programme de Mercatog

**Qwazerty** · 12/01/2012, 20h16

Salut

Visiblement le code de Mercatog est rapide et trouve une solution meilleur...

++
Qwaz

**philppe27** · 12/01/2012, 22h43

Le code de Mercatog est effectivement très rapide et est presque parfait.
J'ai pris les 19 étapes (recopiées telles que dans le tableau) et j'ai lancé le code. En 2 secondes 3976.7 km. En inversant Toulon et Marseille dans le résultat je trouve 3975.7 km !!!!...
J'ai introduit la notion de tri préalable de la zone étape dans la colonne X.
Le principe est que l'étape suivante soit la plus proche de l'étape précédente.
Je reprends les 3 dernières étapes et je les ordonnance, selon le même principe, par rapport à l'arrivée imposée.
Et là miracle le résultat obtenu est directement 3975.7 km.
Ci-joint le fichier avec le code de Mercatog. En mettant une lettre dans la cellule AA1 le tri préalable est effectué.
Merci pour votre soutien.

**mercatog** · 12/01/2012, 23h15

Bonsoir
Ci-joint un lien pour une fichier expliqué mis en contribution à toute fin utile.http://www.developpez.net/forums/d11...s/#post6448196

Optimisation itinéraires routiers avec étapes

Macros et VBA Excel

Discussions similaires

Partager

Partager